(* FILE:   lsplib.joy *)

    basic-libload.

LIBRA

    _lsplib == true;

(*   - - -            L I S P   I N T E R P R E T E R             - - - *)

(* REFS: SICP p ???, Henderson p 39, p 101 *)

(* - - - - -			E V A L			      - - - - - *)

eval == 					(*  env  exp		*)
(*
	dup2
	swap
	"eval: env = " putchars put newline
	"      exp = " putchars put newline
*)
    [ list ]

    [						(*  eval-compound!	*)
      unswons					(*  env args fun	*)
      [ [ QUOTE
	  first ]
	[ LAMBDA
	  dupd cons [CLOSURE] swoncat ]
	[ IF					(*  env  [[i] [t] [e]]	*)
	  uncons [eval] dip			(*  env  e-i [[t] [e]]	*)
	  swap					(*  env  [[t] [e]] e-i	*)
	  [ null ]
	  [ pop second]				(*  env  [e]		*)
	  [ pop first ]				(*  env  [t]		*)
	  ifte eval ]
	[ DEF					(* env      [name body]	*)
	  uncons first swap			(* env      body   name	*)
	  [ eval ]				(* env    e-b		*)
	  dip					(* env    e-b	name	*)
	  dup					(* env    e-b   n    n	*)
	  [ [[] cons] unary2			(* env   [e-b] [n]	*)
	    swons				(* env   [[n] e-b]	*)
	    swons ]				(* [[[n] e-b] env]	*)
	  dip ]					(* new-env            n	*)
	[ DEFUN					(* e  [name vars body]	*)
	  uncons				(* e      n   [vs b]	*)
	  [LAMBDA] swoncat			(* e      n [L vs b]	*)
	  [] cons cons				(* e     [n [L vs b]]	*)
	  [DEF] swoncat				(* e   [D n [L vs b]]	*)
	  eval ]
	[ (* DEFAULT *)
	  swons [eval] map unswons		(*  env  ev-args ev-fun	*)
	  apply ] ]
      case ]

    [						(* eval-atomic		*)
      [ [numerical] [string] sequor ]
	[ ]					(* self-evaluating	*)
	[					(* lookup!		*)
	  dupd swap				(*  env  v  env		*)
	  [					(*  member?		*)
	    [ null ]
	    [ true ]				(*  fake		*)
	    [ first first in ]			(*  really ?		*)
	    ifte ]
	  [ [ null ]				(*  was fake ?		*)
	    [ pop ]				(*  self-evaluating	*)
	    [					(*  search really	*)
	      first unswons rolldown		(*  [e1..] [v1..] v	*)
	      [ [first] dip = ]
	      [ pop pop first ]
	      [ [ [rest] unary2] dip ]
	      tailrec ]
	    ifte ]
	  [ rest ]
	  tailrec ]				(* end lookup!		*)
	ifte ]					(* end eval-atomic	*)

    ifte;					(* end eval		*)

(* - - - - -			A P P L Y		      - - - - - *)

apply ==
(*
    dup2
    "apply: fun = " putchars putln
    "      args = " putchars putln
*)
    [ list ]

    [						(* apply-compound	*)
      unswons
      [ [ CLOSURE				(* args [e v body]	*)
	  unswons call swons
	  uncons swapd uncons			(* dissect the closure	*)
	  [ swap cons				(* build new frame	*)
	    swons ]				(* install new frame	*)
	  dip eval				(* new-env body		*)
	  popd ]				(* restore old env	*)
	[ "apply: unknown procedure type -\n"
	  putchars abort ] ]
      case ]

    [						(* apply-atomic		*)
      [ [ CAR first first ]
	[ CDR first rest ]
	[ CONS uncons first cons ]
	[ EQ uncons first equal ]
	[ ATOM first leaf ]
	[ NULL first null ]
	[ LIST (* do nothing *) ]
	[ (* try Joy: *)
	  [i] dip call ] ]
      case ]

    ifte;					(* end apply		*)


(* - - - - -			  L I B			      - - - - - *)

lib0 ==
	[
	  [ [ FOLDR ]
	    [ CLOSURE lib0 [lis ini bin]
	      IF [NULL lis] ini
		 [bin [CAR lis]
		      [FOLDR [CDR lis] ini bin] ] ] ]
	  [ [ FOLDL ]
	    [ CLOSURE lib0 [lis ini bin]
	      IF [NULL lis] ini
		 [FOLDL [CDR lis]
			[bin [CAR lis] ini]
			bin ] ] ]
	  [ [ FOLDR2 ]
	    [ CLOSURE lib0 [l1 l2 ini tern]
	      IF [or [NULL l1] [NULL l2]] ini
		 [ tern [CAR l1] [CAR l2]
		        [FOLDR2 [CDR l1] [CDR l2] ini tern] ] ] ]
	  [ [ RECFOLDR ]
	    [ CLOSURE lib0 [x y bin]
	      IF [ATOM x]
		 [bin x y]
		 [IF [NULL x]
		     y
		     [RECFOLDR [CAR x]
			       [RECFOLDR [CDR x]
					 y
					 bin]
			       bin] ] ] ]
	  (* other definitions could go here, candidates are:
		 LINREC  BINREC  Y					*)
	    ];

(* - - - - -		  L I S P  (read-eval-print)	      - - - - - *)

l-prompt == "L: ";

lisp ==
	[ "\nLisp interpreter\n"
	  "\t\tTo include the Lisp library, type\n"
	  "\t\t\t[ include  \"OK\"  \"lsplib.lsp\" ]\n"
	  "GO\n\n" ]
	putstrings
	lib0						(* load lib0	*)
	l-prompt putchars get
	[ "EXIT" = not ]
	[ eval putln
	  l-prompt putchars get ]
	while
	pop pop
	"exit from Lisp interpreter\n" putchars;

    LSPLIB == "lsplib.joy - (eval-apply) Lisp interpreter\n".

							(* end LIBRA	*)

"lsplib  is loaded\n" putchars.

(* END   lsplib.joy *)