perm filename CNVR.LSP[RUT,LSP] blob sn#345123 filedate 1978-03-22 generic text, type T, neo UTF8
(DECLARE (DEFP **ARRAY *SUBR FSUBR))

(DEFV INTERNSTR T)

(DEFP *DELETE DELETE FSUBR)

(DEFP *ENTER ENTER SUBR)

(REMOB DELETE ENTER)

(DEFP VALUE EVAL LSUBR)

(DECLARE (SPECIAL CSYSFNS DATUM CEXPRS OBLIST NEWFNS))

(DEFPROP CDUMP
 (LAMBDA (X)
  (PROG (DATUM CEXPRS)
	(COND [(NULL (CDR X)) (SETQ X (LIST (CAR X) @CEXPR @DATUM))])
	(COND [(MEMQ @CEXPR X)
	       (MAPATOMS @(LAMBDA (X)
			   (COND [(AND [GET X @CEXPR] [NOT (MEMQ X CSYSFNS)])
				  (SETQ CEXPRS (CONS X CEXPRS))])))])
	(COND [(MEMQ @DATUM X)
	       (MAPATOMS @(LAMBDA (X)
			   (COND [(GET X @DATUM) (SETQ DATUM (CONS X DATUM))])))
	       ])
	(EVAL (CONS @DSKOUT
		    (LIST (CAR X)
			  @(NILL)
			  @CEXPRS
			  @DATUM
			  @(PRINT @(DATA))
			  @(MAPC (FUNCTION (LAMBDA (Y) (PRINT Y))) DATUM)
			  @(PRINT NIL))))))
 FEXPR)

(DEFV CSYSFNS (UNREALIZE RUNDAEMONS TRY-NEXT TBLOCK GENERATE REALIZE ADIEU 
	       AU-REVOIR IN-CONTEXT ADD REMOVE LISTEN))

(DEFPROP BOUNDP
 (LAMBDA (X)
  (PROG (Y)
	(SETQ Y (GET X @VALUE))
	(COND [(NOT (OR [NULL Y] [EQ (CDR Y) (UNBOUND)])) (RETURN Y)])))
 EXPR)

(DEFV NEWFNS (NIL))

(DEFPROP = (LAMBDA (X Y) (EQ X Y)) EXPR)

(DEFPROP > (LAMBDA (X Y) (*GREAT X Y)) EXPR)

(DEFPROP < (LAMBDA (X Y) (*LESS X Y)) EXPR)

(DEFPROP + (LAMBDA (X Y) (*PLUS X Y)) EXPR)

(DEFPROP MAKREADTABLE
 (LAMBDA (X)
  (NCONC NEWFNS (NCONS (CONS @MAKREADTABLE X))))
 EXPR)

(DEFV PRETTYPROPS (EXPR FEXPR MACRO (VALUE . PP-VALUE) CEXPR DATUM CINT 
		   CPRINT BACKTRACE))

(DEFPROP PI-OFF (LAMBDA (X) (NILL X)) FEXPR)

(DEFPROP PI-ON (LAMBDA (X) (NILL X)) FEXPR)

(DEFPROP SSTATUS (LAMBDA (X) (NILL X)) FEXPR)

(DEFPROP DELQ
 (LAMBDA (WHAT FROM TIMES)
  (COND [(NULL FROM) FROM]
	[TIMES (COND [(EQ WHAT (CAR FROM)) (CDR FROM)]
		     [T (RPLACD FROM (DELQ WHAT (CDR FROM) TIMES))])]
	[(EQ WHAT (CAR FROM)) (DELQ WHAT (CDR FROM) TIMES)]
	[T (DREMOVE WHAT FROM)]))
 EXPR)

(DEFPROP DELETE
 (LAMBDA (WHAT FROM TIMES)
  (COND [(NULL FROM) FROM]
	[TIMES (COND [(EQUAL WHAT (CAR FROM)) (CDR FROM)]
		     [T (RPLACD FROM (DELETE WHAT (CDR FROM) TIMES))])]
	[T (COND [(EQUAL WHAT (CAR FROM)) (DELQ WHAT (CDR FROM) TIMES)]
		 [T (RPLACD FROM (DELETE WHAT (CDR FROM) TIMES))])]))
 EXPR)

(DECLARE (SPECIAL OBARRAY READTABLE ERRLIST BASE IBASE))

(DECLARE (SPECIAL *TOP UARGS BODY EARGS CHALOBV BVARS ALINK CLINK EXP FRAME*
		  FREEVARS FRAMEVARS LEVNUM PC RUNF TEM TEM1 TYPE VAL VARS
		  CINTERRUPT SERRLI ALLOW READY GLOBALS * ** ←)
	 (*FEXPR CDEFGEN CDEFUN CERR CONNIVER CSETQ /: /@ /,)
	 (*LEXPR MATCH ACCESS CONTROL CSET RVALUE VLOC RUN TRYASSIGN VALUE))

(DEFV RUNF NIL)

(DEFV SERRLI NIL)

(DEFV ** **)

(DEFV GLOBALS ((NIL NIL) (T T)))

(DEFV *TOP *TOP)

(*** THE FRAME FORMAT IS AS FOLLOWS ((IVARS . PC) (BVARS . ALINK) EXP . CLINK))

(DEFV FREEVARS (VAL VARS UARGS BODY EARGS TEM TEM1 ALLOW))

(DEFV FRAMEVARS (CHALOBV FRAME* BVARS ALINK CLINK EXP CINTERRUPT READY))

(DEFPROP BVARS
 (LAMBDA (L) (LIST @CAADR (CADR L)))
 MACRO)

(DEFPROP ALINK
 (LAMBDA (L) (LIST @CDADR (CADR L)))
 MACRO)

(DEFPROP EXP
 (LAMBDA (L) (LIST @CADDR (CADR L)))
 MACRO)

(DEFPROP CLINK
 (LAMBDA (L) (LIST @CDDDR (CADR L)))
 MACRO)

(DEFPROP BODY
 (LAMBDA (L) @(CADR (ASSOC @*BODY BVARS)))
 MACRO)

(*** THE HACK REALLY BEGINS HERE -- RUN1 IS THE SYSTEM DRIVER)

(DEFPROP RUN
 (LAMBDA L
  (SETQ VAL (COND [(= L 1Q) (ARG 1Q)] [T NIL]))
  (EVAL @(RUN1)))
 EXPR)

(DEFPROP RUN1
 (LAMBDA NIL
  (COND [RUNF (CERR CONNIVER ALREADY RUNNING)])
  ((LAMBDA (BASE IBASE READTABLE)
    (PROG (RUNF ERET)
	  (PROGN (SETQ RUNF T) (SETQ ERRLIST SERRLI))
     ERRL (SETQ ERET 
		(ERRSET (PROG NIL
			 LOOP (COND [(AND CINTERRUPT ALLOW) (SETQ PC (HANDLE))]
				    [(SETQ PC (CAP PC))])
			      (GO LOOP))))
	  (COND [(EQ ERET @%%%STOP) (RETURN VAL)]
		[(NULL ERET) (SETQ TEM1 @(GO (CEVAL EAR)))])
	  (GO ERRL)))
   12Q 
   12Q 
   (GET @CONNIVREAD @ARRAY)))
 EXPR)

(DEFPROP CAP (LAMBDA (P) (APPLY# P NIL)) EXPR)

(DEFPROP HANDLE
 (LAMBDA NIL
  (PROG2 0Q 
	 (DISPATCH (PROG2 0Q 
			  (CAR CINTERRUPT)
			  (SETQ CINTERRUPT (CDR CINTERRUPT)))
		   PC 
		   FREEVARS 
		   @*TOP)
	 (SETQ ALLOW NIL)))
 EXPR)

(DEFPROP START
 (LAMBDA NIL
  (COND [RUNF (CERR CONNIVER ALREADY RUNNING)])
  (MAPC @(LAMBDA (V) (SET V NIL)) (APPEND FRAMEVARS FREEVARS))
  (PROGN (SETQ PC @ICEVAL)
	 (SETQ EXP @(CEVAL @(LISTEN @TOP-LEVEL)))
	 (SETQ LEVNUM 0Q)
	 (SETQ ALLOW T))
  (EVAL @(RUN1)))
 EXPR)

(DEFPROP STOP
 (LAMBDA N
  (BREAK1 NIL (NOT RUNF) @CONNIVER-NOT-RUNNING--STOP NIL NIL)
  (COND [(= N 0Q) (SETQ VAL NIL)]
	[(= N 1Q) (SETQ VAL (ARG 1Q))]
	[T (CERR WRONG # OF ARGS)])
  (SETQ PC @POPJ)
  (ERR @%%%STOP))
 EXPR)

(DEFPROP *STOP
 (LAMBDA NIL (SETQ PC @U-LOSE) (ERR @%%%STOP))
 EXPR)

(DEFPROP U-LOSE
 (LAMBDA NIL
  (CERR ATTEMPT TO RUN A CONNIVER PROCESS WITH AN UNDEFINED PC)
  @U-LOSE)
 EXPR)

(DEFPROP CERR
 (LAMBDA (L A)
  (PRINT @**ERROR**)
  (MAPC @(LAMBDA (X)
	  (CPRIN1 (COND [(ATOM X) X] [(EQ (CAR X) @/@) (EVAL (CDR X) A)] [T X]))
	  (PRINC @/ ))
	L)
  (CPRINT EXP)
  (PROG NIL
     LP (TERPRI)
	(PRINT @IN-LISP)
	(TERPRI)
	(PRINC @/::)
	(COND [(EQ (SETQ ** (READ)) @$P) (RETURN NIL)]
	      [(EQ (CAR **) @RETURN) (RETURN (EVAL (CADR **) A))]
	      [T (SETQ * (CPRINT (EVAL ** A)))])
	(SETQ ← **)
	(GO LP)))
 FEXPR)

(DEFPROP EAR
 (LAMBDA NIL
  (PROGN (SETQ CINTERRUPT (CONS @(LISTEN @IN-CONNIVER) CINTERRUPT))
	 (SETQ SERRLI ERRLIST)
	 (SETQ ERRLIST @((RUN1))))
  (ERR @ERROX))
 EXPR)

(DEFPROP TOP
 (LAMBDA NIL
  (PROGN (SETQ SERRLI ERRLIST) (SETQ ERRLIST @((START))))
  (ERR @ERRORX))
 EXPR)

(DEFPROP CINTERRUPT
 (LAMBDA (EXP)
  (NCONC (GET @CINTERRUPT @VALUE) (LIST EXP)))
 EXPR)

(DEFPROP ALLOW
 (LAMBDA (L) (SETQ ALLOW (CAR L)))
 FEXPR)

(*** DISPATCH IS THE "PUSHJ" FOR CONNIVER)

(DECLARE (SPECIAL ALINK1 EXP1 RETAG SAVE))

(DEFPROP DISPATCH
 (LAMBDA (EXP1 RETAG SAVE ALINK1)
  (COND [(NUMBERP EXP1) (SETQ VAL EXP1) RETAG]
	[(ATOM EXP1) (SETQ VAL (IVAL EXP1 ALINK1)) RETAG]
	[T (PROG (V F)
		 (SETQ F (CAR EXP1))
	   BEGIN (COND [(ATOM F)
			(COND [(SETQ V (GETL F @(CINT CEXPR FEXPR FSUBR)))
			       (GO (CAR V))]
			      [T (SAVEUP)
				 (PROGN (SETQ UARGS (CDR EXP1))
					(SETQ EARGS NIL))
				 (RETURN @EVARGS)])]
		       [(EQ (CAR F) @CLAMBDA)
			(SAVEUP)
			(BIND1 @*BODY (CDDR F))
			(PROGN (SETQ VARS (CADR F)) (SETQ UARGS (CDR EXP1)))
			(RETURN @ARGB)]
		       [(EQ (CAR F) @LAMBDA)
			(SAVEUP)
			(PROGN (SETQ UARGS (CDR EXP1)) (SETQ EARGS NIL))
			(RETURN @EVARGS)]
		       [(EQ (CAR F) @*CLOSURE) (SETQ F (CADR F)) (GO BEGIN)]
		       [T (SETQ F (CERR UNKNOWN FUNCTION TYPE (/@ . EXP1)))
			  (GO BEGIN)])
	    CINT (SAVEUP)
		 (RETURN (CADR V))
	   CEXPR (SAVEUP)
		 (BIND1 @*BODY (CDADR V))
		 (PROGN (SETQ VARS (CAADR V)) (SETQ UARGS (CDR EXP1)))
		 (RETURN @ARGB)
	   FEXPR 
	   FSUBR ((LAMBDA (*TOP) (SETQ VAL (EVAL EXP1))) ALINK1)
		 (RETURN RETAG))]))
 EXPR)

(DEFPROP SAVEUP
 (LAMBDA NIL
  (PROGN (SETQ CLINK 
	       (CONS (CONS (SAVEV) RETAG)
		     (COND [(NULL FRAME*)
			    (SETQ CHALOBV NIL)
			    (CONS (CONS BVARS ALINK) (CONS EXP CLINK))]
			   [CHALOBV (SETQ CHALOBV NIL)
				    (CONS (CONS BVARS ALINK) (CDDR FRAME*))]
			   [T (CDR FRAME*)])))
	 (SETQ EXP EXP1)
	 (SETQ ALINK (COND [(EQ ALINK1 @*TOP) CLINK] [T ALINK1]))
	 (SETQ BVARS NIL)
	 (SETQ FRAME* NIL)))
 EXPR)

(DEFPROP SAVEV
 (LAMBDA NIL
  (MAPCAR @(LAMBDA (V) (CONS V (VALUE V))) SAVE))
 EXPR)

(*** FUNCTION CALLS RETURN VIA "POPJ")

(DEFPROP POPJ
 (LAMBDA NIL
  (COND [(SETQ FRAME* CLINK) (RESTORE)] [T @*STOP]))
 EXPR)

(DEFPROP RESTORE
 (LAMBDA NIL
  (PROGN (SETQ BVARS (CAADR FRAME*))
	 (SETQ ALINK (CDADR FRAME*))
	 (SETQ EXP (CADDR FRAME*))
	 (SETQ CLINK (CDDDR FRAME*)))
  (REST1))
 EXPR)

(DEFPROP REST1
 (LAMBDA NIL
  (MAPC @(LAMBDA (X) (SET (CAR X) (CDR X))) (CAAR FRAME*))
  (CDAR FRAME*))
 EXPR)

(DECLARE (UNSPECIAL ALINK1 EXP1 RETAG SAVE))

(DEFPROP BIND1
 (LAMBDA (VAR VAL)
  (PROGN (SETQ BVARS (CONS (LIST VAR VAL) BVARS)) (SETQ CHALOBV T)))
 EXPR)

(DEFPROP CLOSE
 (LAMBDA NIL
  (COND [(ATOM (CAR EXP))]
	[(EQ (CAAR EXP) @*CLOSURE)
	 (PROGN (SETQ ALINK (CADDAR EXP)) (SETQ CHALOBV T))]))
 EXPR)

(*** MOBY BINDER -- NORMAL FUNCTION LISTS)

(DEFPROP ARGB
 (LAMBDA NIL
  (COND [(NOT (OR VARS UARGS)) (CLOSE) @AUXB]
	[(AND VARS UARGS)
	 (COND [(ATOM (CAR VARS))
		(COND [(EQ (CAR VARS) @"OPTIONAL")
		       (SETQ VARS (CDR VARS))
		       (OPTMATCH)]
		      [(EQ (CAR VARS) @"REST")
		       (SETQ VARS (CDR VARS))
		       (RESTMATCH)]
		      [T (DISPATCH (CAR UARGS) @ARGB1 @(VARS UARGS) ALINK)])]
	       [(AND [EQ (CAAR VARS) @QUOTE] [ATOM (CADAR VARS)]) (ARGQ)]
	       [T (CERR BAD DECLARATION)])]
	[(AND VARS [OR [EQ (CAR VARS) @"OPTIONAL"] [EQ (CAR VARS) @"REST"]])
	 (CLOSE)
	 (FINVAR)]
	[T (CERR WRONG # OF ARGS)]))
 EXPR)

(DEFPROP ARGB1
 (LAMBDA NIL
  (BIND1 (CAR VARS) VAL)
  (PROGN (SETQ VARS (CDR VARS)) (SETQ UARGS (CDR UARGS)))
  @ARGB)
 EXPR)

(DEFPROP ARGQ
 (LAMBDA NIL
  (BIND1 (CADAR VARS) (CAR UARGS))
  (PROGN (SETQ VARS (CDR VARS)) (SETQ UARGS (CDR UARGS)))
  @ARGB)
 EXPR)

(*** BIND UP "OPTIONALs" AND "RESTs")

(DEFPROP OPTMATCH
 (LAMBDA NIL
  (COND [(NULL UARGS) (CLOSE) (COND [(NULL VARS) @AUXB] [T @FINVAR])]
	[(ATOM (CAR VARS))
	 (COND [(EQ (CAR VARS) @"OPTIONAL") (SETQ VARS (CDR VARS)) @OPTMATCH]
	       [(EQ (CAR VARS) @"REST") (SETQ VARS (CDR VARS)) @RESTMATCH]
	       [T (DISPATCH (CAR UARGS) @OPTMATCH1 @(VARS UARGS) ALINK)])]
	[(EQ (CAAR VARS) @QUOTE)
	 (COND [(ATOM (CADAR VARS))
		(BIND1 (CADAR VARS) (CAR UARGS))
		(PROGN (SETQ VARS (CDR VARS)) (SETQ UARGS (CDR UARGS)))
		@OPTMATCH]
	       [T (CERR BAD DECLARATION)])]
	[(ATOM (CAAR VARS))
	 (DISPATCH (CAR UARGS) @OPTMATCH1 @(VARS UARGS) ALINK)]
	[(AND [EQ (CAAAR VARS) @QUOTE] [ATOM (CADAAR VARS)])
	 (BIND1 (CADAAR VARS) (CAR UARGS))
	 (PROGN (SETQ VARS (CDR VARS)) (SETQ UARGS (CDR UARGS)))
	 @OPTMATCH]
	[T (CERR BAD DECLARATION)]))
 EXPR)

(DEFPROP OPTMATCH1
 (LAMBDA NIL
  (BIND1 (COND [(ATOM (CAR VARS)) (CAR VARS)] [T (CAAR VARS)]) VAL)
  (PROGN (SETQ VARS (CDR VARS)) (SETQ UARGS (CDR UARGS)))
  @OPTMATCH)
 EXPR)

(DEFPROP RESTMATCH
 (LAMBDA NIL
  (COND [(ATOM (CAR VARS)) (SETQ EARGS NIL) (EVREST)]
	[(AND [EQ (CAAR VARS) @QUOTE] [ATOM (CADAR VARS)])
	 (BIND1 (CADAR VARS) UARGS)
	 (CLOSE)
	 @AUXB]
	[T (CERR BAD DECLARATION)]))
 EXPR)

(DEFPROP EVREST
 (LAMBDA NIL
  (COND [(NULL UARGS) (BIND1 (CAR VARS) (REVERSE EARGS)) (CLOSE) @AUXB]
	[T (DISPATCH (CAR UARGS) @EVREST1 @(VARS UARGS EARGS) ALINK)]))
 EXPR)

(DEFPROP EVREST1
 (LAMBDA NIL
  (PROGN (SETQ UARGS (CDR UARGS)) (SETQ EARGS (CONS VAL EARGS)))
  @EVREST)
 EXPR)

(*** WHEN RUN OUT OF ARGS BUT HAVE SOME "OPTIONALs" OR "RESTs")

(DEFPROP FINVAR
 (LAMBDA NIL
  (COND [(NULL VARS) @AUXB]
	[(ATOM (CAR VARS))
	 (COND [(EQ (CAR VARS) @"OPTIONAL") (SETQ VARS (CDR VARS)) @FINVAR]
	       [(EQ (CAR VARS) @"REST")
		(SETQ VARS (CDR VARS))
		(COND [(ATOM (CAR VARS)) (BIND1 (CAR VARS) NIL) @AUXB]
		      [(AND [EQ (CAAR VARS) @QUOTE] [ATOM (CADAR VARS)])
		       (BIND1 (CADAR VARS) NIL)
		       @AUXB]
		      [T (CERR BAD DECLARATION)])]
	       [T (BIND1 (CAR VARS) @*UNASSIGNED)
		  (SETQ VARS (CDR VARS))
		  @FINVAR])]
	[(EQ (CAAR VARS) @QUOTE)
	 (COND [(ATOM (CADAR VARS))
		(BIND1 (CADAR VARS) @*UNASSIGNED)
		(SETQ VARS (CDR VARS))
		@FINVAR]
	       [T (CERR BAD DECLARATION)])]
	[(ATOM (CAAR VARS)) (DISPATCH (CADAR VARS) @FINVAR1 @(VARS) @*TOP)]
	[(AND [EQ (CAAAR VARS) @QUOTE] [ATOM (CADAAR VARS)])
	 (DISPATCH (CADAR VARS) @FINVAR2 @(VARS) @*TOP)]
	[T (CERR BAD DECLARATION)]))
 EXPR)

(DEFPROP FINVAR1
 (LAMBDA NIL (BIND1 (CAAR VARS) VAL) (FINVAR3))
 EXPR)

(DEFPROP FINVAR2
 (LAMBDA NIL
  (BIND1 (CADAAR VARS) VAL)
  (FINVAR3))
 EXPR)

(DEFPROP FINVAR3
 (LAMBDA NIL (SETQ VARS (CDR VARS)) @FINVAR)
 EXPR)

(*** BINDS "AUX" VARIABLES)

(DEFPROP AUXB
 (LAMBDA NIL
  (SETQ BODY (BODY))
  (COND [(NULL BODY) (POPJ)]
	[(EQ (CAR BODY) @"AUX") (SETQ VARS (CADR BODY)) @AUXB1]
	[T @LINE]))
 EXPR)

(DEFPROP AUXB1
 (LAMBDA NIL
  (COND [(NULL VARS) (SETQ BODY (CDDR (BODY))) @LINE]
	[(ATOM (CAR VARS))
	 (BIND1 (CAR VARS) @*UNASSIGNED)
	 (SETQ VARS (CDR VARS))
	 @AUXB1]
	[(AND [ATOM (CAAR VARS)] [CDAR VARS])
	 (DISPATCH (CADAR VARS) @AUXB2 @(VARS) @*TOP)]
	[T (CERR BAD DECLARATION)]))
 EXPR)

(DEFPROP AUXB2
 (LAMBDA NIL
  (BIND1 (CAAR VARS) VAL)
  (SETQ VARS (CDR VARS))
  @AUXB1)
 EXPR)

(DEFPROP CPROG
 (LAMBDA NIL (BIND1 @*BODY (CDR EXP)) @AUXB)
 EXPR)

(DEFPROP PROG CPROG CINT)

(DEFPROP PROG PROGB BACKTRACE)

(DEFPROP PROGBIND
 (LAMBDA NIL
  (DISPATCH (CADR EXP) @PROGB1 NIL ALINK))
 EXPR)

(DEFPROP PROGBIND PROGBIND CINT)

(DEFPROP PROGBIND PROGBINDB BACKTRACE)

(DEFPROP PROGB1
 (LAMBDA NIL
  (BIND1 @*BODY (CONS @"AUX" (CONS (SETQ VARS VAL) (CDDR EXP))))
  @AUXB1)
 EXPR)

(*** BASIC PROG ITERATION LOOP)

(DEFPROP LINE
 (LAMBDA NIL
  (COND [(NULL BODY) (POPJ)] [T (DISPATCH (CAR BODY) @LINE1 @(BODY) @*TOP)]))
 EXPR)

(DEFPROP LINE1
 (LAMBDA NIL (SETQ BODY (CDR BODY)) @LINE)
 EXPR)

(*** EVALUATES ARGUMENTS TO LISP EXPRS SUBRS AND LSUBRS)

(DEFPROP EVARGS
 (LAMBDA NIL
  (COND [(NULL UARGS)
	 ((LAMBDA (*TOP)
	   (SETQ VAL (APPLY# (CAR EXP) (REVERSE EARGS)))) ALINK)
	 (POPJ)]
	[T (DISPATCH (CAR UARGS) @ARGS1 @(UARGS EARGS) ALINK)]))
 EXPR)

(DEFPROP ARGS1
 (LAMBDA NIL
  (PROGN (SETQ UARGS (CDR UARGS)) (SETQ EARGS (CONS VAL EARGS)))
  @EVARGS)
 EXPR)

(*** LOGICAL FLOW OF CONTROL FUNCTIONS)

(DEFPROP CCOND
 (LAMBDA NIL (SETQ UARGS (CDR EXP)) (CONDLP))
 EXPR)

(DEFPROP CONDLP
 (LAMBDA NIL
  (COND [(NULL UARGS) (POPJ)] [T (DISPATCH (CAAR UARGS) @COND1 @(UARGS) ALINK)])
  )
 EXPR)

(DEFPROP COND1
 (LAMBDA NIL
  (COND [VAL (BIND1 @*BODY (CDAR UARGS)) @AUXB]
	[T (SETQ UARGS (CDR UARGS)) @CONDLP]))
 EXPR)

(DEFPROP COND CCOND CINT)

(DEFPROP COND CONDB BACKTRACE)

(DEFPROP IAND
 (LAMBDA NIL
  (COND [(NULL (SETQ EXP (CDR EXP))) (OR VAL [SETQ VAL T]) (POPJ)]
	[(DISPATCH (CAR EXP) @IAND1 @(EXP) @*TOP)]))
 EXPR)

(DEFPROP IAND1
 (LAMBDA NIL (COND [VAL @IAND] [@POPJ]))
 EXPR)

(DEFPROP AND IAND CINT)

(DEFPROP IOR
 (LAMBDA NIL
  (COND [(NULL (SETQ EXP (CDR EXP))) (SETQ VAL NIL) (POPJ)]
	[(DISPATCH (CAR EXP) @IOR1 @(EXP) @*TOP)]))
 EXPR)

(DEFPROP IOR1
 (LAMBDA NIL (COND [VAL (POPJ)] [T @IOR]))
 EXPR)

(DEFPROP OR IOR CINT)

(*** USERS OF FRAMES -- FLOW OF CONTROL CONTROLLERS)

(DEFPROP CGO
 (LAMBDA NIL
  (DISPATCH (CADR EXP) @GO1 NIL ALINK))
 EXPR)

(DEFPROP GO1
 (LAMBDA NIL
  (COND [(ATOM VAL)
	 (PROG (FR TAG B)
	       (PROGN (SETQ FR ALINK) (SETQ TAG @(/: FOO)))
	       (RPLACA (CDR TAG) VAL)
	    LP (COND [(NULL FR) (SETQ VAL (CERR TAG NOT FOUND)) @GO1]
		     [(SETQ B (ASSOC @*BODY (BVARS FR)))
		      (COND [(SETQ B (MEMBER TAG (CADR B)))
			     (SETQ FRAME* FR)
			     (RESTORE)
			     (SETQ BODY B)
			     (RETURN @LINE)])])
	       (SETQ FR (CLINK FR))
	       (GO LP))]
	[(EQ (CAR VAL) @*TAG) (SETQ FRAME* (CADDR VAL)) (RESTORE)]
	[T (SETQ VAL (CERR BAD TAG)) @GO1]))
 EXPR)

(DEFPROP GO CGO CINT)

(DEFPROP CEXIT
 (LAMBDA NIL
  (DISPATCH (CADR EXP) @EXIT1 NIL ALINK))
 EXPR)

(DEFPROP EXIT1
 (LAMBDA NIL
  (SETQ TEM VAL)
  (COND [(CDDR EXP) (DISPATCH (CADDR EXP) @EXIT2 @(TEM) ALINK)]
	[T (PROG (FR)
		 (SETQ FR ALINK)
	      LP (COND [(NULL FR) (CERR EXIT FROM WHAT?)]
		       [(ASSOC @*BODY (BVARS FR))
			(SETQ CLINK (CLINK FR))
			(RETURN (POPJ))])
		 (SETQ FR (CLINK FR))
		 (GO LP))]))
 EXPR)

(DEFPROP EXIT2
 (LAMBDA NIL
  (PROGN (SETQ CLINK (CLINK (FR VAL))) (SETQ VAL TEM))
  (POPJ))
 EXPR)

(DEFPROP EXIT CEXIT CINT)

(DEFPROP CRETURN
 (LAMBDA NIL
  (DISPATCH (CADR EXP) @RETURN1 NIL ALINK))
 EXPR)

(DEFPROP RETURN1
 (LAMBDA NIL
  (PROG (FR)
	(SETQ FR ALINK)
     LP (COND [(NULL FR) (CERR RETURN FROM WHAT?)]
	      [(AND [ASSOC @*BODY (BVARS FR)] [NOT (EQ (CAR (EXP FR)) @COND)])
	       (SETQ CLINK (CLINK FR))
	       (RETURN (POPJ))])
	(SETQ FR (CLINK FR))
	(GO LP)))
 EXPR)

(DEFPROP RETURN CRETURN CINT)

(DEFPROP CDISMISS
 (LAMBDA NIL
  (COND [(CDR EXP) (SETQ TEM NIL) (DISPATCH (CADR EXP) @EXIT2 @(TEM) ALINK)]
	[T (SETQ VAL NIL) (RETURN1)]))
 EXPR)

(DEFPROP DISMISS CDISMISS CINT)

(DEFPROP CONTINUE
 (LAMBDA NIL
  (DISPATCH (CADR EXP) @CONT1 NIL ALINK))
 EXPR)

(DEFPROP CONTINUE CONTINUE CINT)

(DEFPROP CONT1
 (LAMBDA NIL
  (SETQ TEM VAL)
  (COND [(CDDR EXP) (DISPATCH (CADDR EXP) @CONT2 @(TEM) ALINK)]
	[T (PROGN (SETQ VAL NIL) (SETQ FRAME* (FR TEM))) (RESTORE)]))
 EXPR)

(DEFPROP CONT2
 (LAMBDA NIL (SETQ FRAME* (FR TEM)) (RESTORE))
 EXPR)

(*** RELATIVE EVALUATORS)

(DEFPROP ICEVAL
 (LAMBDA NIL
  (DISPATCH (CADR EXP) @CEVAL1 NIL ALINK))
 EXPR)

(DEFPROP CEVAL1
 (LAMBDA NIL
  (SETQ TEM1 VAL)
  (COND [(CDDR EXP) (DISPATCH (CADDR EXP) @CEVAL2 @(TEM1) ALINK)]
	[T (SETQ VAL (FRAME)) @CEVAL2]))
 EXPR)

(DEFPROP CEVAL2
 (LAMBDA NIL (DISPATCH TEM1 @POPJ NIL (FR VAL)))
 EXPR)

(DEFPROP CEVAL
 (LAMBDA N
  ((LAMBDA (PC EXP ALINK)
    (PROG (CLINK FRAME* BVARS CHALOBV RUNF)
	  (RETURN (RUN1))))
   @ICEVAL
   (LIST @CEVAL (LIST @QUOTE (ARG 1Q)))
   (COND [(> N 1Q) (FR (ARG 2Q))] [T ALINK])))
 EXPR)

(DEFPROP CEVAL ICEVAL CINT)

(DEFPROP CEVAL CEVALB BACKTRACE)

(DEFPROP ICALL
 (LAMBDA NIL
  (DISPATCH (CADR EXP) @CALL1 NIL ALINK))
 EXPR)

(DEFPROP CALL1
 (LAMBDA NIL
  (DISPATCH (CONS VAL (CDDR EXP)) @POPJ NIL ALINK))
 EXPR)

(DEFPROP CALL ICALL CINT)

(DEFPROP INVOKE
 (LAMBDA NIL
  (DISPATCH (CADR EXP) @TRY1 NIL ALINK))
 EXPR)

(DEFPROP INVOKE INVOKE CINT)

(DEFPROP TRY1
 (LAMBDA NIL
  (SETQ TEM VAL)
  (DISPATCH (CADDR EXP) @TRY2 @(TEM) ALINK))
 EXPR)

(DEFPROP TRY2
 (LAMBDA NIL
  (PROGN (SETQ EXP (LIST TEM VAL)) (SETQ FRAME* NIL))
  (PROG (AL METHPAT)
	(COND [(NULL (SETQ AL (MATCH (SETQ METHPAT (PATTERN TEM)) VAL)))
	       (RETURN (POPJ))]
	      [T (SETQ BVARS 
		       (NCONC (LIST (LIST @*CALLPAT VAL)
				    (LIST @*METHPAT METHPAT)
				    (LIST @*CALLALIST (CADR AL))
				    (LIST @*BODY (TEXT TEM)))
			      (CAR AL)))
		 (CLOSE)
		 (RETURN @AUXB)])))
 EXPR)

(DEFPROP TEXT
 (LAMBDA (METH)
  (COND [(ATOM METH) (TEXT (GET METH @DATUM))]
	[(EQ (CAR METH) @*CLOSURE) (TEXT (CADR METH))]
	[T (CADDDR METH)]))
 EXPR)

(DEFPROP FR
 (LAMBDA (E)
  (COND [(EQ (CAR E) @*FRAME) (CADR E)]
	[(EQ (CAR E) @*TAG) (CADDR E)]
	[(EQ (CAR E) @*CLOSURE) (CADDR E)]
	[(EQ (CAR E) @*AU-REVOIR) (CADR E)]
	[T (CERR BAD FRAME SUPPLIED)]))
 EXPR)

(*** IDENTIFIER MANIPULATORS)

(DEFPROP VFRAME
 (LAMBDA N
  (PROG (FR LOC)
	(SETQ FR 
	      (COND [(= N 1Q) ALINK]
		    [(= N 2Q) (FR (ARG 2Q))]
		    [T (CERR WRONG # OF ARGS)]))
     LP (COND [(NULL FR) (RETURN NIL)]
	      [(SETQ LOC (ASSOC (ARG 1Q) (BVARS FR)))
	       (RETURN (LIST @*FRAME (CHAUX FR) LOC))])
	(SETQ FR (ALINK FR))
	(GO LP)))
 EXPR)

(DEFPROP VLOC
 (LAMBDA N
  (PROG (FR LOC)
	(SETQ FR 
	      (COND [(= N 1Q)
		     (COND [(SETQ LOC (ASSOC (ARG 1Q) BVARS)) (RETURN LOC)])
		     ALINK]
		    [(= N 2Q) (FR (ARG 2Q))]
		    [T (CERR WRONG # OF ARGS)]))
     LP (COND [(NULL FR) (RETURN (ASSOC (ARG 1Q) GLOBALS))]
	      [(SETQ LOC (ASSOC (ARG 1Q) (BVARS FR))) (RETURN LOC)])
	(SETQ FR (ALINK FR))
	(GO LP)))
 EXPR)

(DEFPROP RVALUE
 (LAMBDA N
  ((LAMBDA (LOC)
    (COND [LOC (COND [(CDDR LOC) (APPLY# (CADDR LOC) (LIST @RVALUE LOC))])
	       (CADR LOC)]
	  [T (CERR UNBOUND VARIABLE @(ARG 1Q))]))
   (COND [(= N 1Q) (VLOC (ARG 1Q))]
	 [(= N 2Q) (VLOC (ARG 1Q) (ARG 2Q))]
	 [T (CERR WRONG # OF ARGS)])))
 EXPR)

(DECLARE (SPECIAL ID))

(DEFPROP IVAL
 (LAMBDA (ID FR)
  (PROG (ANS)
	(COND [(EQ FR @*TOP)
	       (COND [(SETQ ANS (ASSOC ID BVARS)) (GO FOUND)]
		     [T (SETQ FR ALINK)])])
     LP (COND [(NULL FR)
	       (COND [(SETQ ANS (ASSOC ID GLOBALS)) (GO FOUND)]
		     [T (RETURN (CERR UNBOUND VARIABLE (/@ . ID)))])]
	      [(SETQ ANS (ASSOC ID (BVARS FR))) (GO FOUND)])
	(SETQ FR (ALINK FR))
	(GO LP)
  FOUND (COND [(CDDR ANS) (APPLY# (CADDR ANS) (LIST @/, ANS))])
	(COND [(EQ (SETQ ANS (CADR ANS)) @*UNASSIGNED)
	       (RETURN (CERR UNASSIGNED VARIABLE (/@ . ID)))])
	(RETURN ANS)))
 EXPR)

(DECLARE (UNSPECIAL ID))

(DEFPROP ICSETQ
 (LAMBDA NIL (SETQ UARGS EXP) (CSETQ0))
 EXPR)

(DEFPROP CSETQ0
 (LAMBDA NIL
  (COND [(CDR UARGS)
	 (COND [(AND [ATOM (CADR UARGS)] [CDDR UARGS])
		(DISPATCH (CADDR UARGS) @CSETQ1 @(UARGS) ALINK)]
	       [T (CERR BAD CALL) (POPJ)])]
	[T (POPJ)]))
 EXPR)

(DEFPROP CSETQ1
 (LAMBDA NIL
  ((LAMBDA (LOC)
    (COND [LOC (COND [(CDDR LOC) (APPLY# (CADDR LOC) (LIST @CSET LOC VAL))])
	       (RPLACA (CDR LOC) VAL)]
	  [T (SETQ GLOBALS (CONS (LIST (CADR UARGS) VAL) GLOBALS))]))
   (VLOC (CADR UARGS)))
  (SETQ UARGS (CDDR UARGS))
  @CSETQ0)
 EXPR)

(DEFPROP CSETQ
 (LAMBDA (L) (CSET (CAR L) (EVAL (CADR L))))
 FEXPR)

(DEFPROP CSETQ ICSETQ CINT)

(DEFPROP CSET
 (LAMBDA N
  ((LAMBDA (LOC)
    (COND [LOC (COND [(CDDR LOC) (APPLY# (CADDR LOC) (LIST @CSET LOC (ARG 2Q)))]
		)
	       (RPLACA (CDR LOC) (ARG 2Q))]
	  [T (SETQ GLOBALS (CONS (LIST (ARG 1Q) (ARG 2Q)) GLOBALS))])
    (ARG 2Q))
   (COND [(= N 2Q) (VLOC (ARG 1Q))]
	 [(= N 3Q) (VLOC (ARG 1Q) (ARG 3Q))]
	 [T (CERR WRONG # OF ARGS)])))
 EXPR)

(DEFPROP UNASSIGN
 (LAMBDA (VAR) (CSET VAR @*UNASSIGNED))
 EXPR)

(*** FRAME CONSTRUCTORS)

(DEFPROP CHAUX
 (LAMBDA (FR)
  (COND [(NULL FR) NIL]
	[(EQ (CDAR FR) @AUXB1) (CERR ATTEMPT TO RETURN INCOMPLETE FRAME)]
	[T FR]))
 EXPR)

(DEFPROP TAG
 (LAMBDA (NAME)
  (PROG (FR B TAG)
	(PROGN (SETQ FR ALINK) (SETQ TAG @(/: FOO)))
	(RPLACA (CDR TAG) NAME)
     LP (COND [(NULL FR) (RETURN NIL)]
	      [(SETQ B (ASSOC @*BODY (BVARS FR)))
	       (COND [(SETQ B (MEMBER TAG (CADR B)))
		      (CHAUX FR)
		      (RETURN (LIST @*TAG
				    NAME 
				    (CONS (CONS (LIST (CONS @BODY B)) @LINE)
					  (CDR FR))))])])
	(SETQ FR (CLINK FR))
	(GO LP)))
 EXPR)

(DEFPROP ACTBLOCK
 (LAMBDA NIL
  (PROG (FR B)
	(SETQ FR ALINK)
     LP (COND [(NULL FR) (RETURN NIL)]
	      [(SETQ B (ASSOC @*BODY (BVARS FR)))
	       (CHAUX FR)
	       (COND [(EQ (CAR B) @"AUX") (SETQ B (CDDR B))])
	       (RETURN (LIST @*TAG
			     @*ACTBLOCK
			     (CONS (CONS (LIST (CONS @BODY B)) @LINE) (CDR FR)))
		)])
	(SETQ FR (CLINK FR))
	(GO LP)))
 EXPR)

(DEFPROP ACCESS
 (LAMBDA N
  (LIST @*FRAME
	(CHAUX (COND [(= N 0Q) (ALINK ALINK)]
		     [(= N 1Q) (ALINK (FR (ARG 1Q)))]
		     [T (CERR WRONG # OF ARGS)]))))
 EXPR)

(DEFPROP CONTROL
 (LAMBDA N
  (LIST @*FRAME
	(CHAUX (COND [(= N 0Q) (CLINK ALINK)]
		     [(= N 1Q) (CLINK (FR (ARG 1Q)))]
		     [T (CERR WRONG # OF ARGS)]))))
 EXPR)

(DEFPROP CLOSURE
 (LAMBDA N
  (COND [(OR [< N 1Q] [> N 2Q]) (CERR WRONG # OF ARGS)])
  (LIST @*CLOSURE (ARG 1Q) (CHAUX (COND [(= N 2Q) (FR (ARG 2Q))] [T ALINK]))))
 EXPR)

(DEFPROP FRAME
 (LAMBDA NIL (LIST @*FRAME (CHAUX ALINK)))
 EXPR)

(*** VERY DANGEROUS USER (HA!) FUNCTIONS)

(DEFPROP SETACCESS
 (LAMBDA (T1 S)
  (PROGN (SETQ T1 (FR T1)) (SETQ S (FR S)))
  (RPLACD (CADR T1) S)
  @BOOM!)
 EXPR)

(DEFPROP SETCONTROL
 (LAMBDA (T1 S)
  (PROGN (SETQ T1 (FR T1)) (SETQ S (FR S)))
  (RPLACD (CDDR T1) S)
  @BOOM!)
 EXPR)

(*** DEBUGGING AIDS)

(DEFPROP EXPRESSION
 (LAMBDA (F) (EXP (FR F)))
 EXPR)

(DEFPROP BACKTRACE
 (LAMBDA N
  (PROG (FR E B M TEM)
	(SETQ FR (FRAME))
	(COND [(= N 0Q) (SETQ M 777777Q)] [T (SETQ M (ARG 1Q))])
	(COND [(= N 2Q) (SETQ TEM (ARG 2Q))])
     LP (COND [(OR [NULL (CADR FR)] [= M 0Q]) (RETURN @END-OF-BACKTRACE)])
	(SETQ E (EXPRESSION FR))
	(COND [(SETQ B (GET (CAR E) @BACKTRACE)) (APPLY# B (LIST FR (CDR E)))]
	      [T (CPRINT E)])
	(COND [TEM (CPRIN1 (CAADR FR))])
	(SETQ FR (CONTROL FR))
	(SETQ M (SUB1 M))
	(GO LP)))
 EXPR)

(DEFPROP LISTENB
 (LAMBDA (FR ARG)
  (PRINT (IVAL @EAR (CADR FR)))
  (CPRIN1 (IVAL @MESSAGE (CADR FR)))
  (PRINC @/ ))
 EXPR)

(DEFPROP LISTEN
 ((MESSAGE)
  "AUX" 
  ((EAR (GENLEV)))
  (ALLOW T)
  (CPRINT MESSAGE)
  (PROGBIND (LIST (/, EAR) @LOOP)
	    (CSET EAR (TAG @EAR))
	    (CSETQ LOOP (TAG @LOOP))
	    (/: EAR)
	    (PRINT EAR)
	    (/: LOOP)
	    (SETQ ← **)
	    (TERPRI)
	    (/@ PRINT @//)
	    (SET @* (CEVAL (SETQ ** (READ))))
	    (/@ CPRINT *)
	    (GO LOOP)))
 CEXPR)

(DEFPROP LISTEN LISTENB BACKTRACE)

(DEFPROP CONDB
 (LAMBDA (FR ARG) (PRINT @COND))
 EXPR)

(DEFPROP PROGB
 (LAMBDA (FR ARG) (PRINT @PROG))
 EXPR)

(DEFPROP CEVALB
 (LAMBDA (FR ARG) (COND [TEM (PRINT @CEVAL)]))
 EXPR)

(DEFPROP UPDATEB (LAMBDA (FR ARG) NIL) EXPR)

(DEFPROP UPDATE UPDATEB BACKTRACE)

(DEFPROP SETB
 (LAMBDA (FR ARG)
  (OR [MEMBER (CAR ARG) @(@* @**)] [PRINT (CONS @SET ARG)]))
 EXPR)

(DEFPROP SET SETB BACKTRACE)

(DEFPROP PROGBINDB
 (LAMBDA (FR ARG) (PRINT @PROGBIND))
 EXPR)

(*** USER INTERFACE)

(DEFPROP CDEFUN
 (LAMBDA (L)
  (PUTPROP (CAR L) (CDR L) @CEXPR)
  (CAR L))
 FEXPR)

(DEFP CDE CDEFUN FSUBR)

(NOCOMPILE (DEFP CDE CDEFUN FEXPR))

(DEFPROP GENLEV
 (LAMBDA NIL
  (READLIST (APPEND @(E A R -) (EXPLODE (SETQ LEVNUM (ADD1 LEVNUM))))))
 EXPR)

(DEFPROP /: (LAMBDA (L) L) FEXPR)

(DEFPROP /: CP-MACR CPRINT)

(DEFPROP /@ (LAMBDA (\L) (EVAL \L)) FEXPR)

(DEFPROP /@ CP-!/" CPRINT)

(DEFPROP /! CP-MACR CPRINT)

(DEFPROP /,
 (LAMBDA (L) (IVAL (CAR L) *TOP))
 FEXPR)

(DEFPROP /, CP-MACR CPRINT)

(DEFPROP CPRIN1
 (LAMBDA (X)
  (PROG (Y)
	(COND [(PATOM X) (PRIN1 X) (RETURN X)]
	      [(AND [LITATOM (CAR X)]
		    [NOT (NUMBERP (CAR X))]
		    [SETQ Y (GET (CAR X) @CPRINT)])
	       (APPLY# Y X)
	       (RETURN X)])
	(SETQ Y X)
	(PRINC @/()
  PLOOP (CPRIN1 (CAR Y))
	(COND [(NULL (SETQ Y (CDR Y))) (PRINC @/)) (RETURN X)]
	      [(PATOM Y) (PRINC @/ /./ ) (PRIN1 Y) (PRINC @/)) (RETURN X)])
	(PRINC @/ )
	(GO PLOOP)))
 EXPR)

(DEFPROP CPRINT
 (LAMBDA (X) (TERPRI) (CPRIN1 X) (PRINC @/ ) X)
 EXPR)

(DEFPROP CP-MACR
 (LAMBDA (E) (PRINC (CAR E)) (PRIN1 (CADR E)))
 FEXPR)

(DEFPROP CP-QUOTE
 (LAMBDA (E) (PRINC @/') (CPRIN1 (CADR E)))
 FEXPR)

(DEFPROP QUOTE CP-QUOTE CPRINT)

(DEFPROP CP-*TAG
 (LAMBDA (TAG)
  (PRINC @/()
  (PRIN1 (CAR TAG))
  (PRINC @/ )
  (CPRIN1 (CADR TAG))
  (PRINC @/ )
  (CPRIN1 (EXP (CADDR TAG)))
  (PRINC @/)))
 FEXPR)

(DEFPROP *TAG CP-*TAG CPRINT)

(DEFPROP *CLOSURE CP-*TAG CPRINT)

(DEFPROP CP-*FRAME
 (LAMBDA (FRAME)
  (PRINC @/()
  (PRIN1 (CAR FRAME))
  (PRINC @/ )
  (CPRIN1 (EXP (CADR FRAME)))
  (PRINC @/)))
 FEXPR)

(DEFPROP *FRAME CP-*FRAME CPRINT)

(DEFPROP *AU-REVOIR CP-*FRAME CPRINT)

(DEFPROP CP-MATCH
 (LAMBDA (E)
  (PRINC (CAR E))
  (COND [(CDDR E) (CPRIN1 (CDR E))] [(CADR E) (CPRIN1 (CADR E))]))
 FEXPR)

(DEFPROP /!' CP-MATCH CPRINT)

(DEFPROP /!@ CP-MATCH CPRINT)

(DEFPROP CP-!/"
 (LAMBDA (E) (PRINC (CAR E)) (CPRIN1 (CDR E)))
 FEXPR)

(DEFPROP COLMAC
 (LAMBDA NIL (LIST @/: (READ)))
 EXPR)

(DEFPROP COMMAC
 (LAMBDA NIL (LIST @/, (READ)))
 EXPR)

(DEFPROP ATMAC
 (LAMBDA NIL (CONS @/@ (READ)))
 EXPR)

(DEFPROP EXMAC
 (LAMBDA NIL
  (PROG (C F)
	(SETQ C (NXTCHR))
	(COND [(EQ C @$)
	       (TYI)
	       (RETURN ((LAMBDA (OBARRAY) (READ)) (GET @CONNIVER @ARRAY)))]
	      [(SETQ F (ASSOC C @((/" /!/") (/@ /!@))))
	       (TYI)
	       (RETURN (CONS (CADR F) (READ)))]
	      [(SETQ F 
		     (ASSOC C 
			    @((? /!?)
			      (/' /!')
			      (> /!>)
			      (/, /!/,)
			      (< /!<)
			      (/; /!;))))
	       (TYI)
	       (SETQ F (CADR F))]
	      [T (PRINT (LIST @BAD @/! @MACRO C)) (ERR @ERRORX)])
	(RETURN (COND [(AND [DELIM (CHRVAL (SETQ C (NXTCHR)))]
			    [NOT (MEMB C @(/( /[))])
		       (LIST F NIL)]
		      [(ATOM (SETQ C (READ))) (LIST F C)]
		      [T (CONS F C)]))))
 EXPR)

(DEFPROP NXTCHR
 (LAMBDA NIL (INTERN (ASCII (PEEKC))))
 EXPR)

(DECLARE (SPECIAL CFRAMES CNUM CONTEXT DATUM CMARKERS TYPE PATTERN GLOBAL INCCON
		  NUMACT NUMCON *CNUM *IF-ADDEDS *IF-NEEDEDS *IF-REMOVEDS
		  *INDEXTHRESHOLD *ITEMS NEW)
	 (*FEXPR /!/" CDEFUN CERR CSETQ /: /, GCCON IF-ADDED IF-NEEDED
		 IF-REMOVED)
	 (*LEXPR BIND ABSENT ADD CEVAL CFRAME CSET VLOC DGET DGET+ DPUT DPUT+
		 DREM DREM+ FETCH FETCHI FETCHM INSERT KILL MATCH NOTE OBJECT
		 POP-CONTEXT PRESENT DATA-INIT PUSH-CONTEXT REAL REALIZE REMOVE
		 RVALUE UNREAL UNREALIZE)
	 (*EXPR ARGS DATUM CMARKERS PATTERN)
	 (**ARRAY FRAMES RFRAMES)
	 (CALL FRAMES RFRAMES))

(SETQ *INDEXTHRESHOLD 12Q)

(DEFPROP OBJECT
 (LAMBDA N
  (LIST @*OBJECT (COND [(= N 0Q) NIL] [(= N 1Q) (ARG 1Q)] [(TMA)])))
 EXPR)

(DEFPROP TMA
 (LAMBDA NIL (CERR TOO MANY ARGUMENTS))
 EXPR)

(DEFPROP TFA
 (LAMBDA NIL (CERR TOO FEW ARGUMENTS))
 EXPR)

(DECLARE (UNSPECIAL CMARKERS TYPE))

(DEFPROP MAKE-METHOD
 (LAMBDA (TYPE BOD)
  (PROG (FIRST OLDM CMARKERS)
	(COND [(ATOM (SETQ FIRST (CAR BOD)))
	       (SETQ CMARKERS 
		     (COND [(SETQ OLDM (GET FIRST @DATUM))
			    (CDR (CMARKERS OLDM))]))
	       (PUTPROP FIRST 
			(NCONC (LIST TYPE FIRST (CADR BOD) (CDDR BOD)) CMARKERS)
			@DATUM)
	       (RETURN FIRST)]
	      [(RETURN (LIST TYPE NIL FIRST (CDR BOD)))])))
 EXPR)

(DECLARE (SPECIAL CMARKERS TYPE))

(DEFPROP IF-NEEDED
 (LAMBDA (A) (MAKE-METHOD @IF-NEEDED A))
 FEXPR)

(DEFPROP IF-ADDED
 (LAMBDA (A) (MAKE-METHOD @IF-ADDED A))
 FEXPR)

(DEFPROP IF-REMOVED
 (LAMBDA (A) (MAKE-METHOD @IF-REMOVED A))
 FEXPR)

(DEFPROP DATA-INIT
 (LAMBDA K
  ((LAMBDA (N M)
    (COND [(BOUNDP @NUMACT)
	   (PROG (I)
		 (SETQ I 0Q)
	    LOOP (COND [(= I NUMACT) (RETURN I)])
		 (PROG (DATA)
		       (SETQ DATA (CDDR (NUMVAL (FRAMES I))))
		 LOOP1 (COND [(NULL DATA) (RETURN DATA)])
		       ((LAMBDA (D)
			 (AND [ATOM D] [RPLACD (CMARKERS D) NIL])) (CAR DATA))
		       (SETQ DATA (CDR DATA))
		       (GO LOOP1))
		 (SETQ I (ADD1 I))
		 (GO LOOP))])
    (PROGN (SETQ NUMCON N) (SETQ INCCON M))
    (ARRAY FRAMES 22Q NUMCON)
    (ARRAY RFRAMES T NUMCON)
    (STORE (FRAMES 0Q) (MAKNUM (LIST @*CFRAME (SETQ *CNUM 0Q)) @FIXNUM))
    (STORE (RFRAMES 0Q) (CDR (NUMVAL (FRAMES 0Q))))
    (CSETQ CONTEXT (CSETQ GLOBAL (LIST @*CONTEXT (NUMVAL (FRAMES 0Q)))))
    (SETQ NUMACT 1Q)
    (PUTPROP @ITEM (SETQ *ITEMS (LIST @*LIST @(PATTERN THING) 0Q)) @*INDEX)
    (PUTPROP @IF-NEEDED
	     (SETQ *IF-NEEDEDS (LIST @*LIST @(PATTERN THING) 0Q))
	     @*INDEX)
    (PUTPROP @IF-ADDED
	     (SETQ *IF-ADDEDS (LIST @*LIST @(PATTERN THING) 0Q))
	     @*INDEX)
    (PUTPROP @IF-REMOVED
	     (SETQ *IF-REMOVEDS (LIST @*LIST @(PATTERN THING) 0Q))
	     @*INDEX))
   (COND [(> K 0Q) (ARG 1Q)] [T 144Q])
   (COND [(> K 1Q) (ARG 2Q)] [T 12Q])))
 EXPR)

(DECLARE (UNSPECIAL PATTERN))

(DEFPROP FETCH
 (LAMBDA N
  (PROG (PATTERN CON)
	(PROGN (SETQ PATTERN (ARG 1Q))
	       (SETQ CON (COND [(GETCONTEXT 1Q N)] [(ARG N)])))
	(RETURN (CONS (LIST @*POSSIBILITIES PATTERN)
		      (CONS @*IGNORE
			    (NCONC (FETCHI1 PATTERN CON)
				   (FETCHM1 PATTERN *IF-NEEDEDS CON)))))))
 EXPR)

(DEFPROP FETCHI
 (LAMBDA N
  (CONS (LIST @*POSSIBILITIES (ARG 1Q))
	(CONS @*IGNORE (FETCHI1 (ARG 1Q) (COND [(GETCONTEXT 1Q N)] [(ARG N)]))))
  )
 EXPR)

(DEFPROP FETCHM
 (LAMBDA N
  (COND [(> N 3Q) (TMA)])
  ((LAMBDA (CON)
    (CONS (LIST @*POSSIBILITIES (ARG 1Q))
	  (CONS @*IGNORE
		(FETCHM1 (ARG 1Q)
			 (COND [(< N 2Q) *IF-NEEDEDS] [(GET (ARG 2Q) @*INDEX)])
			 CON))))
   (COND [(< N 3Q) (/, CONTEXT)] [(ARG 3Q)])))
 EXPR)

(DEFPROP FETCHI1
 (LAMBDA (PATTERN CON)
  (PROG (ALISTS)
	(RETURN (MAPCAN @(LAMBDA (ITEM)
			  (COND [(SETQ ALISTS (MATCH PATTERN (CAR ITEM)))
				 (LIST (LIST @*ITEM ITEM (CAR ALISTS)))]))
			(SEARCH *ITEMS PATTERN T (CDR CON))))))
 EXPR)

(DEFPROP FETCHM1
 (LAMBDA (PATTERN INDEX CON)
  (MAPCAN
   @(LAMBDA (METHOD)
     ((LAMBDA (MRESULT)
       (COND [MRESULT (LIST (CONS @*METHOD
				  (CONS METHOD (NCONC MRESULT (LIST PATTERN)))))
	      ]))
      (MATCH (PATTERN METHOD) PATTERN)))
   (SEARCH INDEX PATTERN NIL (CDR CON))))
 EXPR)

(DECLARE (SPECIAL PATTERN))

(DEFPROP REAL
 (LAMBDA N
  (AND [REALITY (ARG 1Q) (COND [(GETCONTEXT 1Q N)] [(ARG N)])] [ARG 1Q]))
 EXPR)

(DEFPROP UNREAL
 (LAMBDA N
  (AND [NOT (REALITY (ARG 1Q) (COND [(GETCONTEXT 1Q N)] [(ARG N)]))] [ARG 1Q]))
 EXPR)

(DEFPROP PRESENT
 (LAMBDA N
  (PROG (CON PAT CANDIDATES ALISTS)
	(PROGN (SETQ PAT (ARG 1Q))
	       (SETQ CON (COND [(GETCONTEXT 1Q N)] [(ARG N)]))
	       (SETQ CANDIDATES (SEARCH *ITEMS PAT T (CDR CON))))
   LOOP (COND [(NULL CANDIDATES) (RETURN NIL)]
	      [(SETQ ALISTS (MATCH PAT (ITEM (CAR CANDIDATES))))
	       (MAPC @(LAMBDA (PAIR) (CSET (CAR PAIR) (CADR PAIR)))
		     (CAR ALISTS))
	       (RETURN (CAR CANDIDATES))])
	(SETQ CANDIDATES (CDR CANDIDATES))
	(GO LOOP)))
 EXPR)

(DEFPROP ABSENT
 (LAMBDA N
  (UNREAL (DATUM (ARG 1Q)) (COND [(GETCONTEXT 1Q N)] [(ARG N)])))
 EXPR)

(DECLARE (UNSPECIAL PATTERN))

(DEFPROP SEARCH
 (LAMBDA (INDEX PATTERN ITEM CON)
  (MAPCAN @(LAMBDA (THING)
	    (COND [(REALITY1 (CDR (CMARKERS THING)) CON) (LIST THING)]))
	  (ISEARCH INDEX PATTERN ITEM)))
 EXPR)

(DECLARE (SPECIAL PATTERN))

(DEFPROP REALITY
 (LAMBDA (DATUM CON)
  (REALITY1 (CDR (CMARKERS DATUM)) (CDR CON)))
 EXPR)

(DEFPROP REALITY1
 (LAMBDA (CMARKERS CFRAMES)
  (PROG (CM CON)
	(SETQ CON CFRAMES)
   LOOP (COND [(SETQ CM (MFINTERSECT))
	       (OR [INVISIBLE (CADR CM) CON] [RETURN CM])
	       (PROGN (SETQ CMARKERS (CDR CMARKERS))
		      (SETQ CFRAMES (CDR CFRAMES)))
	       (GO LOOP)]
	      [(RETURN NIL)])))
 EXPR)

(DEFPROP DATUM
 (LAMBDA (SKELETON)
  (PROG (CANDIDATES)
	(SETQ CANDIDATES (ISEARCH *ITEMS SKELETON T))
   LOOP (COND [(NULL CANDIDATES) (RETURN (LIST SKELETON))]
	      [(EQUAL (ITEM (CAR CANDIDATES)) SKELETON)
	       (RETURN (CAR CANDIDATES))])
	(SETQ CANDIDATES (CDR CANDIDATES))
	(GO LOOP)))
 EXPR)

(DEFPROP ADD
 (LAMBDA N
  (REALIZE (DATUMIZE (ARG 1Q)) (COND [(GETCONTEXT 1Q N)] [(ARG N)])))
 EXPR)

(DEFPROP ADD
 ((THING "OPTIONAL" (CONTEXT CONTEXT))
  (REALIZE (/@ DATUMIZE (/, THING)) CONTEXT))
 CEXPR)

(DEFPROP CREMOVE
 (LAMBDA N
  (UNREALIZE (DATUMIZE (ARG 1Q)) (COND [(GETCONTEXT 1Q N)] [(ARG N)])))
 EXPR)

(DEFPROP REMOVE
 ((THING "OPTIONAL" (CONTEXT CONTEXT))
  (UNREALIZE (/@ DATUMIZE (/, THING)) CONTEXT))
 CEXPR)

(DEFPROP INSERT
 (LAMBDA N
  ((LAMBDA (D)
    (REVEAL D (COND [(GETCONTEXT 1Q N)] [(ARG N)]))
    D) (DATUMIZE (ARG 1Q))))
 EXPR)

(DEFPROP KILL
 (LAMBDA N
  ((LAMBDA (D)
    (HIDE D (COND [(GETCONTEXT 1Q N)] [(ARG N)]))
    D) (DATUMIZE (ARG 1Q))))
 EXPR)

(DEFPROP ACTUALIZE
 (LAMBDA N
  (REVEAL (ARG 1Q) (COND [(GETCONTEXT 1Q N)] [(ARG N)]))
  (ARG 1Q))
 EXPR)

(DEFPROP UNACTUALIZE
 (LAMBDA N
  (HIDE (ARG 1Q) (COND [(GETCONTEXT 1Q N)] [(ARG N)]))
  (ARG 1Q))
 EXPR)

(DECLARE (UNSPECIAL DATUM) (SPECIAL PAT CON))

(DEFPROP REALIZE
 (LAMBDA N
  (PROG (DATUM CON PAT)
	(PROGN (SETQ DATUM (ARG 1Q))
	       (SETQ CON (COND [(GETCONTEXT 1Q N)] [(ARG N)])))
	(COND [(AND [REVEAL DATUM CON] [SETQ PAT (ITEM DATUM)])
	       (CEVAL @(CALLDEMONS (/@ . PAT) (/@ . *IF-ADDEDS) (/@ . CON)))])
	(RETURN DATUM)))
 EXPR)

(DEFPROP REALIZE
 ((DATUM "OPTIONAL" (CONTEXT CONTEXT))
  "AUX" 
  (PAT)
  (COND [(/@ AND (REVEAL (/, DATUM) (/, CONTEXT)) (CSETQ PAT (ITEM (/, DATUM))))
	 (CALLDEMONS PAT (/@ . *IF-ADDEDS) CONTEXT)])
  DATUM)
 CEXPR)

(DEFPROP UNREALIZE
 (LAMBDA N
  (PROG (DATUM CON PAT)
	(PROGN (SETQ DATUM (ARG 1Q))
	       (SETQ CON (COND [(GETCONTEXT 1Q N)] [(ARG N)])))
	(COND [(AND [HIDE DATUM CON] [SETQ PAT (ITEM DATUM)])
	       (CEVAL @(CALLDEMONS (/@ . PAT) (/@ . *IF-REMOVEDS) (/@ . CON)))])
	(RETURN DATUM)))
 EXPR)

(DEFPROP UNREALIZE
 ((DATUM "OPTIONAL" (CONTEXT CONTEXT))
  "AUX" 
  (PAT)
  (COND [(/@ AND (HIDE (/, DATUM) (/, CONTEXT)) (CSETQ PAT (ITEM (/, DATUM))))
	 (CALLDEMONS PAT (/@ . *IF-REMOVEDS) CONTEXT)])
  DATUM)
 CEXPR)

(DECLARE (SPECIAL DATUM) (UNSPECIAL PAT CON))

(DEFPROP CALLDEMONS
 (LAMBDA (PAT INDEX CONTEXT)
  (CINTERRUPT (LIST @RUNDAEMONS
		    PAT 
		    CONTEXT 
		    (SEARCH INDEX PAT NIL (CDR CONTEXT)))))
 EXPR)

(DEFPROP RUNDAEMONS
 ((@PAT @CONTEXT @METS)
  (ALLOW T)
  (/: TLP)
  (COND [METS (INVOKE (NXTMET) PAT) (GO @TLP)]))
 CEXPR)

(DEFPROP NXTMET
 (LAMBDA (L)
  (PROG2 (SETQ L (CDR (VLOC @METS))) (CAAR L) (RPLACA L (CDAR L))))
 FEXPR)

(DEFPROP REVEAL
 (LAMBDA (DATUM CON)
  (PROG (CM STATUS CMARKERS CFRAMES PATTERN CNUM CFRAME NEW TYPE NUM)
	(PROGN (SETQ CMARKERS (ANALYZE DATUM))
	       (SETQ CFRAMES (SETQ CON (CDR CON)))
	       (SETQ CM (ADDCFRAME (SETQ CFRAME (CAR CON)) CMARKERS))
	       (SETQ CNUM (CADR CFRAME))
	       (SETQ STATUS (CADR CM)))
	(RPLACA (CDR CM) @+)
	(COND [STATUS (RETURN NIL)]
	      [(AND PATTERN NEW [NULL (CDDR CMARKERS)])
	       (INDEX DATUM PATTERN (GET TYPE @*INDEX))])
	(PROGN (SETQ CMARKERS (CDDR CMARKERS)) (SETQ CFRAMES (CDR CFRAMES)))
   LOOP (COND [(SETQ CM (MFINTERSECT))
	       (COND [(SETQ NUM (INVISIBLE (CADR CM) CON))
		      (COND [(EQUAL CNUM NUM)
			     (SETQ NEW NIL)
			     (RPLACA (CDR CM)
				     (OR [DELETE CNUM (CADR CM) 1Q] @+))])]
		     [(SETQ STATUS T)])
	       (PROGN (SETQ CMARKERS (CDR CMARKERS))
		      (SETQ CFRAMES (CDR CFRAMES)))
	       (GO LOOP)]
	      [NEW (RPLACD (CDR CFRAME) (CONS DATUM (CDDR CFRAME)))])
	(RETURN (NOT STATUS))))
 EXPR)

(DEFPROP HIDE
 (LAMBDA (DATUM CON)
  (PROG (PATTERN CFRAMES CMARKERS CNUM STATUS NUM TYPE REM OLD CFRAME CM)
	(PROGN (SETQ CFRAMES (SETQ CON (CDR CON)))
	       (SETQ CMARKERS (ANALYZE DATUM))
	       (SETQ CNUM (CADAR CON)))
	(COND [(SETQ CM (FINDCFRAME (SETQ CFRAME (CAR CFRAMES)) (CDR CMARKERS)))
	       (PROGN (SETQ STATUS (CADR CM)) (SETQ OLD T))
	       (COND [(CDDR CM) (RPLACA (CDR CM) NIL)]
		     [(SETQ REM T)
		      (DELQ CM CMARKERS 1Q)
		      (AND PATTERN 
			   [NULL (CDR CMARKERS)]
			   [UNINDEX DATUM 
				    PATTERN 
				    (GET TYPE @*INDEX)
				    (EQ TYPE @ITEM)])])])
	(SETQ CMARKERS (CDR CMARKERS))
   LOOP (COND [(SETQ CM (MFINTERSECT))
	       (COND [(SETQ NUM (INVISIBLE (CADR CM) CON))
		      (COND [REM (SETQ REM (NOT (EQUAL CNUM NUM)))]
			    [(OR OLD [SETQ OLD (EQUAL CNUM NUM)])])]
		     [(PROGN (SETQ REM NIL) (SETQ STATUS T)) (CANCEL CM CNUM)])
	       (PROGN (SETQ CMARKERS (CDR CMARKERS))
		      (SETQ CFRAMES (CDR CFRAMES)))
	       (GO LOOP)]
	      [REM (RPLACD (CDR CFRAME) (DELQ DATUM (CDDR CFRAME) 1Q))]
	      [(AND STATUS [NOT OLD])
	       (RPLACD (CDR CFRAME) (CONS DATUM (CDDR CFRAME)))])
	(RETURN STATUS)))
 EXPR)

(DEFPROP ADDCFRAME
 (LAMBDA (CFRAME CMARKERS)
  (PROG (N)
	(SETQ N (CADR CFRAME))
   LOOP (COND [(OR [NULL (CDR CMARKERS)] [LESSP (CAADR CMARKERS) N])
	       (RPLACD CMARKERS (CONS (LIST N NIL) (CDR CMARKERS)))
	       (SETQ NEW T)]
	      [(EQ N (CAADR CMARKERS))]
	      [T (SETQ CMARKERS (CDR CMARKERS)) (GO LOOP)])
	(RETURN (CADR CMARKERS))))
 EXPR)

(DEFPROP FINDCFRAME
 (LAMBDA (CFRAME CMARKERS)
  (PROG (NF NM)
	(SETQ NF (CADR CFRAME))
   LOOP (COND [(NULL CMARKERS) (RETURN NIL)]
	      [(> NF (SETQ NM (CAAR CMARKERS))) (RETURN NIL)]
	      [(> NM NF) (SETQ CMARKERS (CDR CMARKERS)) (GO LOOP)]
	      [(RETURN (CAR CMARKERS))])))
 EXPR)

(DEFPROP CANCEL
 (LAMBDA (CM NUM)
  (RPLACA (CDR CM) (MERGEN NUM (CADR CM))))
 EXPR)

(DEFPROP MERGEN
 (LAMBDA (N NL)
  (COND [(ATOM NL) (LIST N)]
	[(> N (CAR NL)) (CONS N NL)]
	[(RPLACD NL (MERGEN N (CDR NL)))]))
 EXPR)

(DEFPROP MERGE
 (LAMBDA (NL1 NL2)
  (COND [(ATOM NL1) NL2]
	[(ATOM NL2) NL1]
	[(> (CAR NL1) (CAR NL2)) (CONS (CAR NL1) (MERGE (CDR NL1) NL2))]
	[(> (CAR NL2) (CAR NL1)) (CONS (CAR NL2) (MERGE NL1 (CDR NL2)))]
	[(CONS (CAR NL1) (MERGE (CDR NL1) (CDR NL2)))]))
 EXPR)

(DEFPROP DPUTCF
 (LAMBDA (DATUM PROPERTY INDICATOR CFRAME)
  (PROG (PATTERN TYPE CM TAIL NEW)
	(PROGN (SETQ TAIL (ANALYZE DATUM)) (SETQ CM (ADDCFRAME CFRAME TAIL)))
	(COND [NEW (RPLACD (CDR CFRAME) (CONS DATUM (CDDR CFRAME)))
		   (AND PATTERN 
			[NULL (CDDR TAIL)]
			[INDEX DATUM PATTERN (GET TYPE @*INDEX)])])
	(RETURN (DPUT1 CM PROPERTY INDICATOR))))
 EXPR)

(DEFPROP DGETCF
 (LAMBDA (DATUM INDICATOR CFRAME)
  (ASSOC INDICATOR (FINDCFRAME CFRAME (CDR (CMARKERS DATUM)))))
 EXPR)

(DEFPROP DREMCF
 (LAMBDA (DATUM INDICATOR CFRAME)
  (PROG (CMARKERS PATTERN TYPE CM PAIR)
	(PROGN (SETQ CMARKERS (ANALYZE DATUM))
	       (SETQ CM (FINDCFRAME CFRAME (CDR CMARKERS))))
	(COND [(AND CM [SETQ PAIR (ASSOC INDICATOR (CDDR CM))])
	       (DELQ PAIR (CDR CM) 1Q)
	       (COND [(NOT (OR [CADR CM] [CDDR CM]))
		      (DELQ CM CMARKERS 1Q)
		      (DELQ DATUM CFRAME 1Q)])
	       (COND [(AND PATTERN [NULL (CDR CMARKERS)])
		      (UNINDEX DATUM PATTERN (GET TYPE @*INDEX) (EQ TYPE @ITEM))
		      ])
	       (RETURN PAIR)])))
 EXPR)

(DEFPROP DPUT
 (LAMBDA N
  (DPUTCF (ARG 1Q)
	  (ARG 2Q)
	  (ARG 3Q)
	  (CADR (COND [(GETCONTEXT 3Q N)] [(ARG N)]))))
 EXPR)

(DEFPROP DGET
 (LAMBDA N
  ((LAMBDA (CONTEXT)
    (DGET1 (CDR (CMARKERS (ARG 1Q))) (ARG 2Q) (CDR CONTEXT) NIL))
   (COND [(GETCONTEXT 2Q N)] [(ARG N)])))
 EXPR)

(DEFPROP DREM
 (LAMBDA N
  (DREM1 (ARG 1Q) (ARG 2Q) (CDR (COND [(GETCONTEXT 2Q N)] [(ARG N)])) NIL))
 EXPR)

(DEFPROP DPUT+
 (LAMBDA N
  ((LAMBDA (CM)
    (COND [CM (DPUT1 CM (ARG 2Q) (ARG 3Q))] [(CERR ABSENT DATUM)]))
   (REALITY (ARG 1Q) (COND [(GETCONTEXT 3Q N)] [(ARG N)]))))
 EXPR)

(DEFPROP DGET+
 (LAMBDA N
  (DGET1 (CDR (CMARKERS (ARG 1Q)))
	 (ARG 2Q)
	 (CDR (COND [(GETCONTEXT 2Q N)] [(ARG N)]))
	 T))
 EXPR)

(DEFPROP DREM+
 (LAMBDA N
  (DREM1 (ARG 1Q) (ARG 2Q) (CDR (COND [(GETCONTEXT 2Q N)] [(ARG N)])) T))
 EXPR)

(DEFPROP DPUT1
 (LAMBDA (CM PROPERTY INDICATOR)
  (PROG (PAIR)
	(COND [(SETQ PAIR (ASSOC INDICATOR (CDDR CM)))
	       (OR [CDR PAIR] [RPLACD (CDR PAIR) (NCONS NIL)])
	       (RPLACA (CDR PAIR) PROPERTY)]
	      [(RPLACD (CDR CM)
		       (CONS (SETQ PAIR (LIST INDICATOR PROPERTY)) (CDDR CM)))])
	(RETURN PAIR)))
 EXPR)

(DEFPROP DGET1
 (LAMBDA (CMARKERS INDICATOR CFRAMES SIGN)
  (PROG (PAIR CM CON)
	(SETQ CON CFRAMES)
   LOOP (COND [(NULL (SETQ CM (MFINTERSECT))) (RETURN NIL)]
	      [(AND SIGN [INVISIBLE (CADR CM) CON])]
	      [(SETQ PAIR (ASSOC INDICATOR (CDDR CM))) (RETURN PAIR)])
	(PROGN (SETQ CMARKERS (CDR CMARKERS)) (SETQ CFRAMES (CDR CFRAMES)))
	(GO LOOP)))
 EXPR)

(DEFPROP DREM1
 (LAMBDA (DATUM INDICATOR CFRAMES SIGN)
  (PROG (PAIR CMARKERS TAIL PATTERN TYPE CM CON)
	(PROGN (SETQ CON CFRAMES)
	       (SETQ CMARKERS (CDR (SETQ TAIL (ANALYZE DATUM)))))
   LOOP (COND [(NULL (SETQ CM (MFINTERSECT))) (RETURN NIL)]
	      [(AND SIGN [INVISIBLE (CADR CM) CON])]
	      [(SETQ PAIR (ASSOC INDICATOR (CDDR CM)))
	       (DELQ PAIR (CDR CM) NIL)
	       (COND [(NOT (OR [CADR CM] [CDDR CM]))
		      (DELQ CM TAIL NIL)
		      (DELQ DATUM (CAR CFRAMES) NIL)])
	       (COND [(AND PATTERN [NULL (CDR TAIL)])
		      (UNINDEX DATUM PATTERN (GET TYPE @*INDEX) (EQ TYPE @ITEM))
		      ])
	       (RETURN PAIR)])
	(PROGN (SETQ CMARKERS (CDR CMARKERS)) (SETQ CFRAMES (CDR CFRAMES)))
	(GO LOOP)))
 EXPR)

(DEFPROP MENTIONERS
 (LAMBDA N
  (PROG (CFRAMES CMARKERS MENTIONERS SIGN CM CON)
	(COND [(< N 1Q) (TFA)])
	(PROGN (SETQ CFRAMES 
		     (CDR (COND [(< N 3Q) (/, CONTEXT)]
				[(= N 3Q) (ARG 3Q)]
				[(TMA)])))
	       (SETQ SIGN (COND [(> N 1Q) (ARG 2Q)]))
	       (SETQ CMARKERS (CDR (CMARKERS (ARG 1Q))))
	       (SETQ CON CFRAMES))
   LOOP (COND [(SETQ CM (MFINTERSECT))
	       (OR [AND SIGN [INVISIBLE (CADR CM) CON]]
		   [SETQ MENTIONERS (CONS (CAR CFRAMES) MENTIONERS)])
	       (PROGN (SETQ CFRAMES (CDR CFRAMES))
		      (SETQ CMARKERS (CDR CMARKERS)))
	       (GO LOOP)])
	(RETURN (REVERSE MENTIONERS))))
 EXPR)

(DECLARE (UNSPECIAL DATUM))

(DEFPROP C-MARKER
 (LAMBDA (DATUM CFRAME)
  (FINDCFRAME CFRAME (CDR (CMARKERS DATUM))))
 EXPR)

(DECLARE (SPECIAL DATUM))

(DEFPROP MFINTERSECT
 (LAMBDA NIL
  (PROG (NM NF CM)
 ADVANCE 
	(COND [(AND CMARKERS CFRAMES)
	       (PROGN (SETQ NF (CADAR CFRAMES))
		      (SETQ CM (CAR CMARKERS))
		      (SETQ NM (CAR CM)))]
	      [(RETURN NIL)])
   TEST (COND [(> NF NM)
	       (OR [SETQ CFRAMES (CDR CFRAMES)] [RETURN NIL])
	       (SETQ NF (CADAR CFRAMES))
	       (GO TEST)]
	      [(> NM NF)
	       (OR [SETQ CMARKERS (CDR CMARKERS)] [RETURN NIL])
	       (PROGN (SETQ CM (CAR CMARKERS)) (SETQ NM (CAR CM)))
	       (GO TEST)]
	      [(RETURN CM)])))
 EXPR)

(DECLARE (UNSPECIAL CMARKERS))

(DEFPROP INVISIBLE
 (LAMBDA (CNUMS CFRAMES)
  (AND [NOT (EQ CNUMS @+)]
       [OR [NULL CNUMS]
	   [PROG (NC NF)
		 (SETQ NC (CAR CNUMS))
	    LOOP (COND [CFRAMES (SETQ NF (CADAR CFRAMES))
				(SETQ CFRAMES (CDR CFRAMES))]
		       [(RETURN NIL)])
	    TEST (COND [(> NF NC) (GO LOOP)]
		       [(> NC NF)
			(OR [SETQ CNUMS (CDR CNUMS)] [RETURN NIL])
			(SETQ NC (CAR CNUMS))
			(GO TEST)]
		       [(RETURN NC)])]]))
 EXPR)

(DECLARE (UNSPECIAL CFRAMES))

(DEFPROP GETCONTEXT
 (LAMBDA (K N)
  (COND [(< N K) (TFA)]
	[(= N K) (/, CONTEXT)]
	[(= N (SETQ K (ADD1 K))) NIL]
	[(TMA)]))
 EXPR)

(DECLARE (UNSPECIAL PATTERN))

(DEFPROP ISEARCH
 (LAMBDA (INDEX PATTERN ITEM)
  (APPLY# (FUNCTION APPEND) (CDR (ISEARCH1 INDEX PATTERN ITEM))))
 EXPR)

(DEFPROP ISEARCH1
 (LAMBDA (INDEX PATTERN ITEM)
  (PROG (ASCAR ASCDR)
	(COND [(NULL INDEX) (RETURN (LIST 0Q))]
	      [(EQ (CAR INDEX) @*LIST)
	       (RETURN (CONS (CADDR INDEX) (LIST (CDDDR INDEX))))]
	      [(EQ (CAR INDEX) @*INDEX)]
	      [T (BREAK1 NIL T @BAD-STRUCTURE-INDEX--ISEARCH NIL NIL)])
	(RETURN (COND [(OR [ZEROP (CAR (SETQ ASCAR 
					     (ASEARCH (CADDR INDEX)
						      (CAR PATTERN)
						      ITEM)))]
			   [NULL (CDR PATTERN)]
			   [> (CAR (SETQ ASCDR 
					 (ASEARCH (CDDDR INDEX)
						  (CDR PATTERN)
						  ITEM)))
			      (CAR ASCAR)])
		       ASCAR]
		      [ASCDR]))))
 EXPR)

(DEFPROP ASEARCH
 (LAMBDA (SUBINDEX ELEMENT ITEM)
  (PROG (INDICATOR ASSOCIATION CLLIST VLIST)
	(COND [(EQ (SETQ INDICATOR (ATOMIZE ELEMENT)) @*VARIABLE)
	       (RETURN (LIST 10000Q))])
	(SETQ CLLIST 
	      (COND [(EQ INDICATOR @*STRUCTURE)
		     (ISEARCH1 (CAR SUBINDEX) ELEMENT ITEM)]
		    [(SETQ ASSOCIATION (ASSQ1 INDICATOR (CDR SUBINDEX)))
		     (CONS (CADR ASSOCIATION) (LIST (CDDR ASSOCIATION)))]
		    [(LIST 0Q)]))
	(COND [(AND [NOT ITEM]
		    [SETQ ASSOCIATION (ASSOC @*VARIABLE (CDR SUBINDEX))]
		    [SETQ VLIST (CDDR ASSOCIATION)])
	       (RPLACA CLLIST (+ (CAR CLLIST) (CADR ASSOCIATION)))
	       (RPLACD CLLIST (CONS VLIST (CDR CLLIST)))])
	(RETURN CLLIST)))
 EXPR)

(DEFPROP ASSQ1
 (LAMBDA (IND ALIST)
  (COND [(NUMBERP IND) (ASSOC# IND ALIST)] [(ASSOC IND ALIST)]))
 EXPR)

(DECLARE (SPECIAL THING PFORM INDEX))

(DEFPROP INDEX
 (LAMBDA (THING PATTERN INDEX)
  (PROG (NUM THINGS PFORM)
	(COND [(NULL INDEX) (BREAK1 NIL T @BAD-INDEX--INDEX NIL NIL)]
	      [(EQ (CAR INDEX) @*LIST)
	       (COND [(EQUAL (SETQ NUM (ADD1 (CADDR INDEX))) *INDEXTHRESHOLD)
		      (RPLACA INDEX @*INDEX)
		      (PROGN (SETQ THINGS (CDDDR INDEX))
			     (SETQ PFORM (CADR INDEX)))
		      (RPLACD (CDR INDEX) (LIST (LIST NIL) NIL))
		      (MAPC (/!/" LAMBDA 
				  (THING)
				  (INDEX THING (/@ . PFORM) INDEX))
			    THINGS)]
		     [T (RPLACD (CDR INDEX)
				(CONS NUM (CONS THING (CDDDR INDEX))))
			(RETURN THING)])]
	      [(EQ (CAR INDEX) @*INDEX) (SETQ PFORM (CADR INDEX))]
	      [(BREAK1 NIL T @BAD-INDEX--INDEX NIL NIL)])
	(INDEX1 THING (CAR PATTERN) (CADDR INDEX) @CAR PFORM)
	(AND [CDR PATTERN]
	     [INDEX1 THING (CDR PATTERN) (CDDDR INDEX) @CDR PFORM])
	(RETURN THING)))
 EXPR)

(DECLARE (UNSPECIAL PFORM INDEX))

(DEFPROP UNINDEX
 (LAMBDA (THING PATTERN INDEX ITEM)
  (COND [(NULL INDEX) (BREAK1 NIL T @BAD-INDEX--UNINDEX NIL NIL)]
	[(EQ (CAR INDEX) @*LIST)
	 (RPLACD (CDR INDEX)
		 (CONS (SUB1 (CADDR INDEX)) (DELTHING THING (CDDDR INDEX) ITEM))
	  )
	 THING]
	[(EQ (CAR INDEX) @*INDEX)
	 (UNINDEX1 THING (CAR PATTERN) (CADDR INDEX) ITEM)
	 (AND [CDR PATTERN] [UNINDEX1 THING (CDR PATTERN) (CDDDR INDEX) ITEM])
	 THING]
	[(BREAK1 NIL T @BAD-INDEX--UNINDEX NIL NIL)]))
 EXPR)

(DECLARE (UNSPECIAL THING))

(DEFPROP INDEX1
 (LAMBDA (THING ELEMENT SUBINDEX POS PFORM)
  (PROG (INDICATOR ASSOCIATION)
	(COND [(EQ (SETQ INDICATOR (ATOMIZE ELEMENT)) @*STRUCTURE)
	       (COND [(NULL (CAR SUBINDEX))
		      (RPLACA SUBINDEX (LIST @*LIST (LIST POS PFORM) 0Q))])
	       (INDEX THING ELEMENT (CAR SUBINDEX))]
	      [(SETQ ASSOCIATION (ASSQ1 INDICATOR (CDR SUBINDEX)))
	       (RPLACD ASSOCIATION 
		       (CONS (ADD1 (CADR ASSOCIATION))
			     (CONS THING (CDDR ASSOCIATION))))]
	      [T (RPLACD SUBINDEX 
			 (CONS (LIST INDICATOR 1Q THING) (CDR SUBINDEX)))])))
 EXPR)

(DEFPROP UNINDEX1
 (LAMBDA (THING ELEMENT SUBINDEX ITEM)
  (PROG (ASSOCIATION INDICATOR NUM)
	(SETQ INDICATOR (ATOMIZE ELEMENT))
	(COND [(EQ INDICATOR @*STRUCTURE)
	       (UNINDEX THING ELEMENT (CAR SUBINDEX) ITEM)]
	      [(SETQ ASSOCIATION (ASSQ1 INDICATOR (CDR SUBINDEX)))
	       (COND [(ZEROP (SETQ NUM (SUB1 (CADR ASSOCIATION))))
		      (DELQ ASSOCIATION SUBINDEX NIL)]
		     [T (RPLACD ASSOCIATION 
				(CONS NUM 
				      (DELTHING THING (CDDR ASSOCIATION) ITEM)))
		      ])])))
 EXPR)

(DECLARE (SPECIAL PATTERN))

(DEFPROP ANALYZE
 (LAMBDA (X)
  (COND [(NULL X) (CERR MEANINGLESS DATUM -- ANALYZE)]
	[(ATOM X) (ANALYZE (GET X @DATUM))]
	[(EQ (CAR X) @*CLOSURE)
	 (PROG2 (ANALYZE (CADR X)) (CDDR X) (SETQ DATUM X))]
	[(EQ (CAR X) @*OBJECT)
	 (PROGN (SETQ PATTERN NIL) (SETQ TYPE @OBJECT))
	 (CDR X)]
	[(ATOM (SETQ TYPE (CAR X)))
	 (SETQ PATTERN (CADDR X))
	 (AND [CADR X] [SETQ DATUM (CADR X)])
	 (CDDDR X)]
	[T (PROGN (SETQ PATTERN (CAR X)) (SETQ TYPE @ITEM)) X]))
 EXPR)

(DECLARE (UNSPECIAL PATTERN))

(DEFPROP CMARKERS
 (LAMBDA (DATUM)
  (COND [(NULL DATUM) (CERR MEANINGLESS DATUM -- CMARKERS)]
	[(ATOM DATUM) (CMARKERS (GET DATUM @DATUM))]
	[(EQ (CAR DATUM) @*CLOSURE) (CDDR DATUM)]
	[(EQ (CAR DATUM) @*OBJECT) (CDR DATUM)]
	[(ATOM (CAR DATUM)) (CDDDR DATUM)]
	[DATUM]))
 EXPR)

(DEFPROP PATTERN
 (LAMBDA (DATUM)
  (COND [(NULL DATUM) (CERR MEANINGLESS DATUM -- PATTERN)]
	[(ATOM DATUM) (PATTERN (GET DATUM @DATUM))]
	[(EQ (CAR DATUM) @*CLOSURE) (PATTERN (CADR DATUM))]
	[(ATOM (CAR DATUM)) (CADDR DATUM)]
	[(CAR DATUM)]))
 EXPR)

(DEFPROP DELTHING
 (LAMBDA (THING LIST ITEM)
  (COND [ITEM (DELITEM (ITEM THING) LIST)] [(DELQ THING LIST T)]))
 EXPR)

(DEFPROP DELITEM
 (LAMBDA (EXP LIST)
  (COND [(NULL LIST) NIL]
	[(EQUAL EXP (ITEM (CAR LIST))) (CDR LIST)]
	[T (RPLACD LIST (DELITEM EXP (CDR LIST)))]))
 EXPR)

(DEFPROP MEMCAR
 (LAMBDA (EXP LIST)
  (COND [(NULL LIST) NIL]
	[(EQUAL EXP (ITEM (CAR LIST))) LIST]
	[T (MEMCAR EXP (CDR LIST))]))
 EXPR)

(DEFPROP FIRSTCAR<
 (LAMBDA (N LIST)
  (PROG NIL
   LOOP (COND [(NULL LIST) (RETURN NIL)]
	      [(< (CAAR LIST) N) (RETURN LIST)]
	      [T (SETQ LIST (CDR LIST)) (GO LOOP)])))
 EXPR)

(DEFPROP ITEM
 (LAMBDA (DATUM)
  (COND [(NULL DATUM) (CERR MEANINGLESS DATUM)]
	[(ATOM DATUM) (ITEM (GET DATUM @DATUM))]
	[((LAMBDA (PAT) (AND [NOT (ATOM PAT)] PAT)) (CAR DATUM))]))
 EXPR)

(DEFPROP DATUMIZE
 (LAMBDA (THING)
  (COND [(ATOM THING) THING] [(DATUM THING)]))
 EXPR)

(DEFPROP ATOMIZE
 (LAMBDA (ELEMENT)
  (COND [(ATOM ELEMENT) ELEMENT]
	[(ACTOR (CAR ELEMENT)) @*VARIABLE]
	[T @*STRUCTURE]))
 EXPR)

(DEFPROP PUSH-CONTEXT
 (LAMBDA N
  (CONS @*CONTEXT (CONS (CFRAME) (CDR (COND [(GETCONTEXT 0Q N)] [(ARG N)])))))
 EXPR)

(DEFPROP POP-CONTEXT
 (LAMBDA N
  (CONS @*CONTEXT (CDDR (COND [(GETCONTEXT 0Q N)] [(ARG N)]))))
 EXPR)

(DECLARE (UNSPECIAL CFRAMES))

(DEFPROP NEW-CONTEXT
 (LAMBDA (CFRAMES)
  (COND [(ORDERED CFRAMES) (CONS @*CONTEXT CFRAMES)] [(CERR UNORDERED CONTEXT)])
  )
 EXPR)

(DECLARE (SPECIAL CFRAMES))

(DEFPROP SPLICE
 (LAMBDA (CONTEXT)
  (RPLACD (CDR CONTEXT)
	  (CONS (CFRAME (NEWCNUM (CADR (CADDR CONTEXT)) (CADADR CONTEXT)))
		(CDDR CONTEXT)))
  CONTEXT)
 EXPR)

(DECLARE (SPECIAL EXPR))

(DEFPROP IN-CONTEXT
 (LAMBDA (CONTEXT EXPR)
  (CEVAL @((CLAMBDA (CONTEXT) (CEVAL (/@ . EXPR))) (/@ . CONTEXT))))
 EXPR)

(DEFPROP IN-CONTEXT
 ((CONTEXT EXPR) (CEVAL EXPR))
 CEXPR)

(DECLARE (UNSPECIAL EXPR))

(DEFPROP PATH
 (LAMBDA (C)
  (CONS @*CONTEXT (MAPCAR @CADR (CDR C))))
 EXPR)

(DECLARE (SPECIAL PATTERN))

(DEFPROP FINALIZE
 (LAMBDA (CON)
  (PROG (CF CF2 DATA CN CN2 DATUM PATTERN TYPE TAIL NEW OLD CM CM2 PAIR2 SW)
	(SETQ CON (CDR CON))
	(SETQ CF (CAR CON))
	(SETQ DATA (CDR CF))
	(SETQ CN (CAR DATA))
	(SETQ CF2 (CADR CON))
	(SETQ CN2 (CADR CF2))
   LOOP (COND [(NULL (SETQ DATA (CDR DATA)))
	       (RETURN (CONS @*CONTEXT (CDR CON)))])
	(SETQ DATUM (CAR DATA))
	(SETQ TAIL (ANALYZE DATUM))
	(COND [(SETQ CM (FINDCFRAME CF (CDR TAIL)))
	       (SETQ CM2 (ADDCFRAME CF2 TAIL))
	       (SETQ SW (CADR CM))
	       (SETQ OLD (NOT NEW))]
	      [(SETQ CM2 (SETQ OLD (FINDCFRAME CF2 (CDR TAIL))))])
	(COND [CM (MAPC (FUNCTION (LAMBDA (PAIR)
				   (COND [(SETQ PAIR2 (ASSOC (CAR PAIR) CM2))
					  (RPLACD PAIR2 (CDR PAIR))]
					 [(RPLACD (CDR CM2)
						  (CONS PAIR (CDDR CM2)))])))
			(CDDR CM))])
	(COND [SW (RPLACA (CDR CM2) (OR [MERGE (CADR CM) (CADR CM2)] @+))]
	      [T (COND [(AND CM2 [NOT (ATOM (CADR CM2))] [MEMBER CN (CADR CM2)])
			(HIDE DATUM CON)
			(GO LOOP)])
		 (MAPC (FUNCTION (LAMBDA (CM3)
				  (COND [(AND [NOT (ATOM (CADR CM3))]
					      [MEMBER CN (CADR CM3)])
					 (SETQ NEW T)
					 (OR OLD 
					     [SETQ OLD (MEMBER CN2 (CADR CM3))])
					 (RPLACA (CDR CM3)
						 (MERGEN CN2 (CADR CM3)))])))
		       (FIRSTCAR< CN2 (CDR TAIL)))])
	(AND NEW [NOT OLD] [RPLACD (CDR CF2) (CONS DATUM (CDDR CF2))])
	(GO LOOP)))
 EXPR)

(DECLARE (UNSPECIAL PATTERN))

(DEFPROP CFRAME
 (LAMBDA K
  ((LAMBDA (NFRAME)
    (COND [(AND [= NUMACT NUMCON] [PROG2 (GC) (= (GCCON) NUMCON)])
	   (CERR TOO MANY CONTEXT-FRAMES)])
    (STORE (FRAMES NUMACT) (MAKNUM NFRAME @FIXNUM))
    (STORE (RFRAMES NUMACT) (CDR NFRAME))
    (SETQ NUMACT (ADD1 NUMACT))
    NFRAME)
   (LIST @*CFRAME
	 (COND [(ZEROP K) (SETQ *CNUM (PLUS INCCON *CNUM))] [T (ARG 1Q)]))))
 EXPR)

(DEFPROP ORDERED
 (LAMBDA (CLIST)
  (OR [NULL CLIST]
      [PROG NIL
       LOOP (COND [(CDR CLIST)
		   (OR [< (CADADR CLIST) (CADAR CLIST)] [RETURN NIL])
		   (SETQ CLIST (CDR CLIST))
		   (GO LOOP)])
	    (RETURN T)]))
 EXPR)

(DEFPROP NEWCNUM
 (LAMBDA (LOW HIGH)
  (PROG (N INC INUSE)
	(PROGN (SETQ N (*QUO (PLUS LOW HIGH) 2Q))
	       (SETQ INUSE (CNUMSINUSE LOW HIGH))
	       (SETQ INC 1Q))
   LOOP (COND [(GREATERP HIGH N LOW)
	       (COND [(MEMBER N INUSE)
		      (PROGN (SETQ N (PLUS N INC))
			     (SETQ INC (DIFFERENCE 0Q (ADD1 INC))))
		      (GO LOOP)]
		     [(RETURN N)])]
	      [(CERR NO NEW CNUM BETWEEN 
				       (* LOW) AND 
				       (* HIGH))])))
 EXPR)

(DEFPROP CNUMSINUSE
 (LAMBDA (LOW HIGH)
  (PROG (I NUMS J N)
	(PROGN (SETQ I 0Q) (SETQ J (SUB1 NUMACT)))
   LOOP (COND [(> I J) (RETURN NUMS)]
	      [(OR [> LOW (SETQ N (CAR (RFRAMES I)))] [> N HIGH])]
	      [(SETQ NUMS (CONS N NUMS))])
	(SETQ I (ADD1 I))
	(GO LOOP)))
 EXPR)

(DEFPROP *GCCON
 (LAMBDA NIL
  (PROG (M N)
	(PROGN (SETQ N 0Q) (SETQ M NUMACT))
  NGCLP (COND [(= M N) (RETURN N)]
	      [(EQ (CDR (NUMVAL (FRAMES N))) (RFRAMES N))
	       (SETQ N (ADD1 N))
	       (GO NGCLP)])
	(FLUSH (RFRAMES N))
	(STORE (RFRAMES N) 0Q)
  MGCLP (SETQ M (SUB1 M))
	(COND [(= M N) (RETURN N)]
	      [(EQ (CDR (NUMVAL (FRAMES M))) (RFRAMES M)) (GO EXCH)])
	(FLUSH (RFRAMES M))
	(STORE (RFRAMES M) 0Q)
	(GO MGCLP)
   EXCH (STORE (FRAMES N) (FRAMES M))
	(STORE (RFRAMES N) (RFRAMES M))
	(STORE (RFRAMES M) 0Q)
	(GO NGCLP)))
 EXPR)

(DEFPROP GCCON
 (LAMBDA (L) (SETQ L (SETQ NUMACT (*GCCON))) L)
 FEXPR)

(DECLARE (SPECIAL PATTERN))

(DEFPROP FLUSH
 (LAMBDA (CFRAME)
  (PROG (DATUM THINGS N PATTERN TYPE CMARKERS)
	(PROGN (SETQ THINGS (CDR CFRAME)) (SETQ N (CAR CFRAME)))
   LOOP (COND [(NULL THINGS) (RETURN NIL)])
	(COND [(AND [REMCFRAME N 
			       (SETQ CMARKERS 
				     (ANALYZE (SETQ DATUM (CAR THINGS))))]
		    PATTERN 
		    [NULL (CDR CMARKERS)])
	       (UNINDEX DATUM PATTERN (GET TYPE @*INDEX) (EQ TYPE @ITEM))])
	(SETQ THINGS (CDR THINGS))
	(GO LOOP)))
 EXPR)

(DECLARE (UNSPECIAL PATTERN))

(DEFPROP REMCFRAME
 (LAMBDA (N CMARKERS)
  (PROG (M CM REMSW)
  LOOP1 (COND [(NULL (CDR CMARKERS)) (RETURN NIL)]
	      [(= N (SETQ M (CAADR CMARKERS)))
	       (COND [(PROG1 (CADADR CMARKERS)
			     (RPLACD CMARKERS (CDDR CMARKERS)))
		      (RETURN T)])
	       (SETQ REMSW T)]
	      [(> N M) (SETQ CMARKERS (CDR CMARKERS)) (GO LOOP1)])
  LOOP2 (SETQ CMARKERS (CDR CMARKERS))
	(COND [(NULL CMARKERS) (RETURN REMSW)]
	      [(ATOM (CADR (SETQ CM (CAR CMARKERS))))
	       (AND [MEMBER N (CADR CM)]
		    [RPLACA (CDR CM) (OR [DELETE N (CADR CM) 1Q] @+)])])
	(GO LOOP2)))
 EXPR)

(DEFPROP /!/" (LAMBDA (L) (/!/"1 L)) FEXPR)

(DEFPROP /!/" CP-!/" CPRINT)

(DEFPROP /!/"1
 (LAMBDA (L)
  (COND [(ATOM L) L]
	[(EQ (CAR L) @/@) (EVAL (CDR L))]
	[(EQ (CAR L) @/,) (IVAL (CADR L) @*TOP)]
	[(ATOM (CAR L)) (CONS (CAR L) (/!/"1 (CDR L)))]
	[(EQ (CAAR L) @/!@) (APPEND (EVAL (CDAR L)) (/!/"1 (CDR L)))]
	[T (CONS (/!/"1 (CAR L)) (/!/"1 (CDR L)))]))
 EXPR)

(DEFPROP KTH
 (LAMBDA (LST NUM) (CAR (NTH LST NUM)))
 EXPR)

(DECLARE (SPECIAL TEM TEM1 TEM2 ALINK BVARS EXP CLINK FRAME* VAL)
	 (*FEXPR CERR INSTANCE PROPOSE /,)
	 (*LEXPR CSET VFRAME ACCESS CONTROL))

(DEFPROP ALINK
 (LAMBDA (L) (LIST @CDADR (CADR L)))
 MACRO)

(DEFPROP CLINK
 (LAMBDA (L) (LIST @CDDDR (CADR L)))
 MACRO)

(DEFPROP TRY-NEXT
 ((POSSIBILITIES "OPTIONAL" (NOMORE NIL) (MESSAGE NIL))
  "AUX" 
  (POS)
  (/: TRY-NEXT)
  (GO (NEXT))
  (/: EXIT)
  (RETURN (CEVAL NOMORE (ACCESS)))
  (/: RETURN)
  (RETURN POS)
  (/: *METHOD)
  (METGO)
  (/: *GENERATOR)
  (GENGO)
  (/: *AU-REVOIR)
  (REGO)
  (/: *BLOCK)
  (TBLOCK))
 CEXPR)

(DEFPROP NEXT
 (LAMBDA (L)
  (SETQ L (/, POSSIBILITIES))
  (COND [(OR [ATOM L] [NOT (EQ (CAAR L) @*POSSIBILITIES)])
	 (CERR BAD POSSIBILITIES LIST)])
  (PROG (P)
	(COND [(NULL (CDR L)) (RETURN @EXIT)])
	(UNBLOCK (CDR L))
     TN (COND [(NULL (CDDR L)) (RETURN @EXIT)])
	(RPLACD L (CDDR L))
	(COND [(EQ (SETQ P (CADR L)) @*IGNORE) (GO TN)]
	      [(ATOM P) (CSET @POS P) (RETURN @RETURN)]
	      [(EQ (CAR P) @*ITEM)
	       (SETUP (CADDR P))
	       (CSET @POS (CADR P))
	       (RETURN @RETURN)]
	      [(EQ (CAR P) @*NOTE)
	       (SETUP (CADR P))
	       (CSET @POS P)
	       (RETURN @RETURN)]
	      [(MEMQ (CAR P) @(*METHOD *GENERATOR *AU-REVOIR *BLOCK))
	       (RETURN (CAR P))]
	      [T (CSET @POS P) (RETURN @RETURN)])))
 FEXPR)

(DEFPROP SETUP
 (LAMBDA (ALIST)
  (SETQ TEM (ACCESS))
  (MAPC @(LAMBDA (PAIR)
	  (CSET (CAR PAIR) (CADR PAIR) TEM)) ALIST))
 EXPR)

(DEFPROP GENGO
 (LAMBDA NIL
  (PROGN (SETQ TEM (CDR (IVAL @POSSIBILITIES ALINK)))
	 (SETQ BVARS (LIST (LIST @NEXT TEM)))
	 (SETQ CLINK (FR (TAG @TRY-NEXT)))
	 (SETQ ALINK (ALINK CLINK))
	 (SETQ TEM1 (CADAR TEM))
	 (SETQ FRAME* NIL))
  (RPLACA TEM (LIST @*BLOCK))
  (DISPATCH TEM1 @POPJ NIL @*TOP))
 EXPR)

(DEFPROP GENGO GENGO CINT)

(DEFPROP METGO
 (LAMBDA NIL
  (PROGN (SETQ TEM (CDR (IVAL @POSSIBILITIES ALINK)))
	 (SETQ TEM1 (CADAR TEM))
	 (SETQ BVARS 
	       (NCONC (LIST (LIST @NEXT TEM)
			    (LIST @*BODY (TEXT TEM1))
			    (LIST @*CALLPAT (CADDDR (CDAR TEM)))
			    (LIST @*METHPAT (PATTERN TEM1))
			    (LIST @*CALLALIST (CADDDR (CAR TEM)))
			    (LIST @*METHALIST (CADDAR TEM)))
		      (CADDAR TEM)))
	 (SETQ EXP (LIST TEM1 (CADDDR (CDAR TEM))))
	 (SETQ FRAME* NIL)
	 (SETQ CLINK (FR (TAG @TRY-NEXT)))
	 (SETQ ALINK (ALINK CLINK)))
  (CLOSE)
  (RPLACA TEM (LIST @*BLOCK))
  @AUXB)
 EXPR)

(DEFPROP METGO METGO CINT)

(DEFPROP REGO
 (LAMBDA NIL
  (PROGN (SETQ TEM (CDR (IVAL @POSSIBILITIES ALINK)))
	 (SETQ VAL (IVAL @MESSAGE ALINK))
	 (SETQ FRAME* (CADAR TEM)))
  (SETCONTROL (VFRAME @NEXT (CAR TEM)) (TAG @TRY-NEXT))
  (CSET @NEXT TEM (CAR TEM))
  (RPLACA TEM (LIST @*BLOCK))
  (RESTORE))
 EXPR)

(DEFPROP REGO REGO CINT)

(DEFPROP TBLOCK
 (NIL (NCONC (CADR POSSIBILITIES) (TAG @TRY-NEXT))
      (ALLOW NIL)
      (COND [(/@ . READY)
	     (CONTINUE (/@ PROG2 (ALLOW T) (CAR READY) (SETQ READY (CDR READY)))
	      )])
      (ALLOW T)
      (LISTEN @ALL-BLOCKED-UP))
 CEXPR)

(DEFPROP UNBLOCK
 (LAMBDA (L)
  (COND [(EQ (CAAR L) @*BLOCK)
	 (NCONC (GET @READY @VALUE) (CDAR L))
	 (RPLACA L @*IGNORE)]))
 EXPR)

(DEFPROP NOTE
 (LAMBDA N
  (COND [(= N 0Q) ((LAMBDA (P) (COND [P (ENTER P)])) (INSTANCE)) 0Q]
	[T (PROG (NEXT M)
		 (PROGN (SETQ M 0Q) (SETQ NEXT (CDR (VLOC @NEXT))))
	      LP (COND [(> (SETQ M (ADD1 M)) N) (RETURN N)])
		 (RPLACD (CAR NEXT) (CONS (ARG M) (CDAR NEXT)))
		 (RPLACA NEXT (CDAR NEXT))
		 (GO LP))]))
 EXPR)

(DEFPROP ADIEU
 (("REST" L) (PROPOSE) (DISMISS (VFRAME @NEXT)))
 CEXPR)

(DEFPROP AU-REVOIR
 (("REST" L)
  (PROPOSE)
  (ENTER (CONS @*AU-REVOIR (CDR (CONTROL))))
  (DISMISS (VFRAME @NEXT)))
 CEXPR)

(DEFPROP ENTER
 (LAMBDA (X)
  (SETQ TEM (CDR (VLOC @NEXT)))
  (RPLACD (CAR TEM) (CONS X (CDAR TEM)))
  (RPLACA TEM (CDAR TEM)))
 EXPR)

(DEFPROP PROPOSE
 (LAMBDA (L)
  (SETQ L (CDR (VLOC @NEXT)))
  (MAPC @(LAMBDA (X)
	  (RPLACD (CAR L) (CONS X (CDAR L)))
	  (RPLACA L (CDAR L)))
	(/, L)))
 FEXPR)

(DEFPROP INSTANCE
 (LAMBDA (L)
  (PROG (NEXTF CALLA)
	(PROGN (SETQ NEXTF (FR (VFRAME @NEXT)))
	       (SETQ CALLA (IVAL @*CALLALIST NEXTF))
	       (SETQ L 
		     (MATCH (IVAL @*CALLPAT NEXTF)
			    (IVAL @*METHPAT NEXTF)
			    CALLA 
			    (IVAL @*METHALIST NEXTF))))
	(COND [L (RETURN (LIST @*NOTE (CPY (CAR L))))])))
 FEXPR)

(DEFPROP CPY
 (LAMBDA (L)
  (MAPCAR @(LAMBDA (X) (LIST (CAR X) (CADR X))) L))
 EXPR)

(DEFPROP GET-POSSIBILITIES
 (LAMBDA NIL
  (IVAL @POSSIBILITIES (CLINK (FR (VFRAME @NEXT)))))
 FEXPR)

(DEFPROP SET-POSSIBILITIES
 (LAMBDA (LIST)
  (CSET @POSSIBILITIES LIST (CONTROL (VFRAME @NEXT))))
 EXPR)

(DEFPROP GENERATE
 ((@FORM)
  "AUX" 
  ((POSSIBILITIES
    (LIST (LIST @*POSSIBILITIES (/, FORM)) (LIST @*GENERATOR (/, FORM)))))
  (GENGO)
  (/: TRY-NEXT)
  POSSIBILITIES)
 CEXPR)

(DECLARE (SPECIAL MALIST MALIST1 MALIST2 MALISTV1 MALISTV2 NOBIND VALV)
	 (*LEXPR MATCH TRYASSIGN RVALUE VLOC)
	 (*FEXPR CERR))

(DEFPROP MATCH
 (LAMBDA N
  ((LAMBDA (VARPAT DATAPAT)
    (PROG (MALIST1 MALIST2 MALISTV1 MALISTV2 NOBIND)
	  (COND [(> N 2Q)
		 (PROGN (SETQ MALIST1 (ARG 3Q))
			(SETQ MALIST2 (ARG 4Q))
			(SETQ NOBIND T))])
	  (PROGN (SETQ MALISTV1 (GET @MALIST1 @VALUE))
		 (SETQ MALISTV2 (GET @MALIST2 @VALUE)))
	  (RETURN (COND [(MATCH1 VARPAT DATAPAT) (LIST MALIST1 MALIST2)]))))
   (ARG 1Q)
   (ARG 2Q)))
 EXPR)

(DECLARE (UNSPECIAL MALIST1 MALIST2))

(DEFPROP MATCH1
 (LAMBDA (VARPAT DATAPAT)
  (PROG (ACTOR1 ACTOR2)
	(RETURN (COND [(ATOM VARPAT) (MATCH2 DATAPAT VARPAT MALISTV2)]
		      [(ATOM DATAPAT) (MATCH2 VARPAT DATAPAT MALISTV1)]
		      [(EQ (SETQ ACTOR2 (CAR DATAPAT)) @/!')]
		      [(MEMQ ACTOR2 @(/!< /!?))
		       (MATCH2 VARPAT 
			       (ACTORSUBST DATAPAT (CDR MALISTV2))
			       MALISTV1)]
		      [(EQ (SETQ ACTOR1 (CAR VARPAT)) @/!>)
		       (/!> (CDR VARPAT) DATAPAT MALISTV1 MALISTV2)]
		      [(EQ ACTOR1 @/!?)
		       (/!? (CDR VARPAT) DATAPAT MALISTV1 MALISTV2 T)]
		      [(EQ ACTOR1 @/!')
		       (MBINDR (CADR VARPAT) (CDDR VARPAT) DATAPAT MALISTV1)]
		      [(EQ ACTOR1 @/!<)
		       (/!< (CADR VARPAT) DATAPAT MALISTV1 MALISTV2)]
		      [(EQ ACTOR1 @/!/,)
		       (COMMA (CDR VARPAT) DATAPAT MALISTV1 MALISTV2)]
		      [(EQ ACTOR1 @/!;)
		       (/!; (CDR VARPAT) DATAPAT MALISTV1 MALISTV2 T)]
		      [(EQ ACTOR2 @/!>)
		       (/!? (CDR DATAPAT) VARPAT MALISTV2 MALISTV1 NIL)]
		      [(EQ ACTOR2 @/!;)
		       (/!; (CDR DATAPAT) VARPAT MALISTV2 MALISTV1 NIL)]
		      [(EQ ACTOR2 @/!/,)
		       (COMMA (CDR DATAPAT) VARPAT MALISTV2 MALISTV1)]
		      [(MATCH1 (CAR VARPAT) (CAR DATAPAT))
		       (MATCH1 (CDR VARPAT) (CDR DATAPAT))]))))
 EXPR)

(DECLARE (UNSPECIAL MALISTV2))

(DEFPROP COMMA
 (LAMBDA (VARSPEC DATAPAT MV1 MV2)
  ((LAMBDA (VAR VALSPEC)
    (COND [VALSPEC ((LAMBDA (VAL)
		     (COND [(MATCH2 DATAPAT VAL MV2) (MBINDV VAR VAL MV1)]))
		    ((LAMBDA (MALIST) (EVAL (CAR VALSPEC))) (CDR MV1)))]
	  [((LAMBDA (VAL)
	     (COND [(EQ VAL @*UNASSIGNED)
		    (TRYASSIGN VAR DATAPAT (CDR MV1) MV2 (EQ MV1 MALISTV1) NIL)]
		   [(MATCH2 DATAPAT VAL MV2)]))
	    ((LAMBDA (MALIST) (/!/,1 VAR)) (CDR MV1)))]))
   (CAR VARSPEC)
   (CDR VARSPEC)))
 EXPR)

(DECLARE (UNSPECIAL MALISTV1))

(DEFPROP MATCH2
 (LAMBDA (VARPAT EXP MV)
  (COND
   [(ATOM VARPAT) (EQUAL VARPAT EXP)]
   [((LAMBDA (ACTOR)
      (COND
       [(MEMQ ACTOR @(/!? /!> /!')) (MBINDR (CADR VARPAT) (CDDR VARPAT) EXP MV)]
       [(EQ ACTOR @/!/,)
	((LAMBDA (VAR VALSPEC)
	  (COND [VALSPEC ((LAMBDA (VAL)
			   (COND [(EQUAL VAL EXP) (MBINDV VAR EXP MV)]))
			  ((LAMBDA (MALIST) (EVAL (CAR VALSPEC))) (CDR MV)))]
		[((LAMBDA (VAL)
		   (COND [(EQ VAL @*UNASSIGNED) (MSET VAR EXP (CDR MV))]
			 [(EQUAL VAL EXP)]))
		  ((LAMBDA (MALIST) (/!/,1 VAR)) (CDR MV)))]))
	 (CADR VARPAT)
	 (CDDR VARPAT))]
       [(EQ ACTOR @/!;)
	(PROG (VAR VALV RS)
	      (PROGN (SETQ VAR (CADR VARPAT)) (SETQ RS (CDDR VARPAT)))
	      (RETURN (COND [(SETQ VALV (ASSOC VAR (CDR MV)))
			     (AND [COND [(EQ (SETQ VALV (CADR VALV))
					     @*UNASSIGNED)
					 (MSET VAR EXP (CDR MV))]
					[(EQUAL VALV EXP)]]
				  [SATISFY RS (CDR MV)])]
			    [(CHECKVAL VAR)
			     (AND [EQUAL VALV EXP] [SATISFY RS (CDR MV)])]
			    [(MBINDR VAR RS EXP MV)])))]
       [(EQ ACTOR @/!<) NIL]
       [(ATOM EXP) NIL]
       [(MATCH2 ACTOR (CAR EXP) MV) (MATCH2 (CDR VARPAT) (CDR EXP) MV)]))
     (CAR VARPAT))]))
 EXPR)

(DEFPROP /!?
 (LAMBDA (VARSPEC PAT VALISTV PALISTV VARSALLOWED)
  ((LAMBDA (VAR RS VARS)
    (COND [VARS (COND [(OR VARSALLOWED [NOT (HASMUSTASSIGNS VARS)])
		       (COND [(HASVARS VARS) (MBINDV VAR @*UNASSIGNED VALISTV)]
			     [(OR [NOT VAR]
				  [MBINDR VAR 
					  RS 
					  (VARSUBST PAT (CDR PALISTV))
					  VALISTV])])])]
	  [T (MBINDR VAR RS PAT VALISTV)]))
   (CAR VARSPEC)
   (CDR VARSPEC)
   (FINDVARS PAT PALISTV)))
 EXPR)

(DEFPROP /!? CP-MATCH CPRINT)

(DEFPROP /!>
 (LAMBDA (VARSPEC PAT VALISTV PALISTV)
  ((LAMBDA (VAR RS VARS)
    (COND [VARS (COND [(HASVARS VARS) NIL]
		      [T (OR [NOT VAR]
			     [MBINDR VAR 
				     RS 
				     (VARSUBST PAT (CDR PALISTV))
				     VALISTV])])]
	  [T (MBINDR VAR RS PAT VALISTV)]))
   (CAR VARSPEC)
   (CDR VARSPEC)
   (FINDVARS PAT PALISTV)))
 EXPR)

(DEFPROP /!> CP-MATCH CPRINT)

(DEFPROP TRYASSIGN
 (LAMBDA N
  (PROG (VARS VAR PAT MALIST PALISTV VARSALLOWED RS)
	(SETQ VARS (FINDVARS (ARG 2Q) (ARG 4Q)))
	(SETQ VAR (ARG 1Q))
	(SETQ PAT (ARG 2Q))
	(SETQ MALIST (ARG 3Q))
	(SETQ PALISTV (ARG 4Q))
	(SETQ VARSALLOWED (ARG 5Q))
	(SETQ RS (ARG 6Q))
	(COND [VARS (COND [(OR VARSALLOWED [NOT (HASMUSTASSIGNS VARS)])
			   (COND [(HASVARS VARS)]
				 [T ((PROG (VAL)
					   (MSET VAR VAL MALIST)
					   (SATISFY RS MALIST))
				     (VARSUBST PAT (CDR PALISTV)))])])]
	      [T (MSET VAR PAT MALIST) (SATISFY RS MALIST)])))
 EXPR)

(DEFPROP /!<
 (LAMBDA (VAR PAT VALISTV PALISTV)
  ((LAMBDA (VARS)
    (COND [VARS (COND [(HASVARS VARS)
		       (OR [NOT VAR]
			   [MBIND VAR (VARSUBST PAT (CDR PALISTV)) VALISTV])])])
    )
   (FINDVARS PAT PALISTV)))
 EXPR)

(DEFPROP /!< CP-MATCH CPRINT)

(DEFPROP /!;
 (LAMBDA (VARSPEC PAT VALISTV PALISTV MUSTBIND)
  (PROG (VAR VALV RS)
	(PROGN (SETQ VAR (CAR VARSPEC)) (SETQ RS (CDR VARSPEC)))
	(RETURN (COND [(SETQ VALV (ASSOC VAR (CDR VALISTV)))
		       (COND [(EQ (SETQ VALV (CADR VALV)) @*UNASSIGNED)
			      (TRYASSIGN VAR 
					 PAT 
					 (CDR VALISTV)
					 PALISTV 
					 MUSTBIND 
					 RS)]
			     [(MATCH2 PAT VALV PALISTV)
			      (SATISFY RS (CDR VALISTV))])]
		      [(CHECKVAL VAR)
		       (AND [MATCH2 PAT VALV PALISTV]
			    [SATISFY RS (CDR VALISTV)])]
		      [MUSTBIND (/!> VARSPEC PAT VALISTV PALISTV)]
		      [(/!? VARSPEC PAT VALISTV PALISTV NIL)]))))
 EXPR)

(DEFPROP /!; CP-MATCH CPRINT)

(DEFPROP CHECKVAL
 (LAMBDA (VAR)
  (COND [(SETQ VALV (VLOC VAR)) (NOT (EQ (SETQ VALV (CADR VALV)) @*UNASSIGNED))]
	[(SETQ VALV (BOUNDP VAR))
	 (NOT (EQ (SETQ VALV (CDR VALV)) @*UNASSIGNED))]))
 EXPR)

(DECLARE (UNSPECIAL VALV))

(DEFPROP FINDVARS
 (LAMBDA (PAT MALISTV)
  (COND
   [(ATOM PAT) NIL]
   [((LAMBDA (CAR)
      (COND [(EQ CAR @/!/,)
	     ((LAMBDA (VAR VALSPEC)
	       (COND [(OR [NULL VALSPEC] NOBIND)
		      (GETSPEC @/!/, VAR (CDR MALISTV))]
		     [(MBINDV VAR 
			      ((LAMBDA (MALIST) (EVAL (CAR VALSPEC)))
			       (CDR MALISTV))
			      MALISTV)
		      (LIST @NIL)]))
	      (CADR PAT)
	      (CDDR PAT))]
	    [(EQ CAR @/!;)
	     ((LAMBDA (VAR MALIST)
	       (COND [(ASSIGNED? VAR) (LIST NIL)]
		     [(OR NOBIND [ASSOC VAR MALIST]) (GETSPEC @/!; VAR MALIST)]
		     [(MBINDV VAR @*UNASSIGNED MALISTV) (LIST @/!>)]))
	      (CADR PAT)
	      (CDR MALISTV))]
	    [(ACTOR CAR)
	     (COND [NOBIND (GETSPEC CAR (CADR PAT) (CDR MALISTV))]
		   [(MBINDV (CADR PAT) @*UNASSIGNED MALISTV) (LIST CAR)])]
	    [(NCONC (FINDVARS CAR MALISTV) (FINDVARS (CDR PAT) MALISTV))]))
     (CAR PAT))]))
 EXPR)

(DEFPROP HASMUSTASSIGNS
 (LAMBDA (VARS)
  (PROG (V)
	(SETQ V VARS)
   LOOP (COND [(NULL V) (RETURN V)])
	(AND [MEMQ (CAR V) @(/!> /!')] [RETURN T])
	(SETQ V (CDR V))
	(GO LOOP)))
 EXPR)

(DEFPROP HASVARS
 (LAMBDA (VARS)
  (PROG (V)
	(SETQ V VARS)
   LOOP (COND [(NULL V) (RETURN V)])
	(AND [CAR V] [RETURN T])
	(SETQ V (CDR V))
	(GO LOOP)))
 EXPR)

(DEFPROP VARSUBST
 (LAMBDA (PAT MALIST)
  (COND [(ATOM PAT) PAT]
	[(ACTOR (CAR PAT)) (ACTORSUBST PAT MALIST)]
	[(CONS (VARSUBST (CAR PAT) MALIST) (VARSUBST (CDR PAT) MALIST))]))
 EXPR)

(DEFPROP ACTOR
 (LAMBDA (ATOM)
  (MEMQ ATOM @(/!> /!? /!' /!< /!/, /!;)))
 EXPR)

(DEFPROP ACTORSUBST
 (LAMBDA (PAT MALIST)
  ((LAMBDA (VAR)
    ((LAMBDA (VAL)
      (COND [(EQ VAL @*UNASSIGNED) PAT] [VAL])) (/!/,1 VAR)))
   (CADR PAT)))
 EXPR)

(DEFPROP GETSPEC
 (LAMBDA (ACTOR VAR MALIST)
  (COND [(EQ (/!/,1 VAR) @*UNASSIGNED)
	 (COND [NOBIND (CERR UNASSIGNED VARIABLE IN INSTANCE)] [(LIST ACTOR)])]
	[(LIST NIL)]))
 EXPR)

(DEFPROP MBIND
 (LAMBDA (VAR VAL ALISTV)
  (COND [NOBIND (MSET VAR VAL (CDR ALISTV))]
	[(RPLACD ALISTV (CONS (LIST VAR VAL) (CDR ALISTV)))]))
 EXPR)

(DEFPROP MBINDV
 (LAMBDA (VAR VAL ALISTV)
  (COND [(NOT VAR)]
	[NOBIND (MSET VAR VAL (CDR ALISTV))]
	[(RPLACD ALISTV (CONS (LIST VAR VAL) (CDR ALISTV)))]))
 EXPR)

(DECLARE (UNSPECIAL NOBIND))

(DEFPROP MBINDR
 (LAMBDA (VAR RESTRICTIONS VAL ALISTV)
  (OR [NOT VAR]
      [AND [MBIND VAR VAL ALISTV] [SATISFY RESTRICTIONS (CDR ALISTV)]]))
 EXPR)

(DEFPROP /!/,
 (LAMBDA (L) (/!/,1 (CAR L)))
 FEXPR)

(DEFPROP /!/, CP-MATCH CPRINT)

(DEFPROP /!/,1
 (LAMBDA (VAR/ )
  ((LAMBDA (PAIR)
    (COND [PAIR (CADR PAIR)] [(RVALUE VAR/ )])) (ASSOC VAR/  MALIST)))
 EXPR)

(DEFPROP SATISFY
 (LAMBDA (RS MALIST)
  (OR [NULL RS] [APPLY# (FUNCTION AND) RS]))
 EXPR)

(DECLARE (UNSPECIAL MALIST))

(DEFPROP MSET
 (LAMBDA (VAR VAL MALIST)
  ((LAMBDA (PAIR)
    (COND [PAIR (RPLACA (CDR PAIR) VAL) VAL]
	  [(CERR VARIABLE @VAR UNBOUND IN MATCH ALIST)])
    T)
   (ASSOC VAR MALIST)))
 EXPR)

(DEFPROP ASSIGNED?
 (LAMBDA (VAR)
  (PROG (VAL)
	(RETURN (COND [(SETQ VAL (VLOC VAR)) (NOT (EQ (CADR VAL) @*UNASSIGNED))]
		      [(SETQ VAL (BOUNDP VAR))
		       (NOT (EQ (CDR VAL) @*UNASSIGNED))]))))
 EXPR)

(DEFPROP CNVINT
 (LAMBDA NIL (SETQ RUNF NIL) (START))
 EXPR)

(PROGN
(DEFPROP CNVRINIT
 (LAMBDA NIL
  (MODCHR 47Q (MODCHR 100Q NIL))
  (DRM /@ ATMAC)
  (DRM /: COLMAC)
  (DRM /! EXMAC)
  (DRM /, COMMAC)
  (DRM /; EXMAC)
  (DEFLIST (@"'"
	    (/! "!")
	    (/, ",")
	    (/: ":")
	    (/!/" PP-!/")
	    (/@ PP-!/")
	    /!' 
	    /!/, 
	    /!; 
	    /!< 
	    /!> 
	    /!? 
	    /!@)
	   PP-MATCH 
	   PRINTMACRO)
  T)
 EXPR)

(DEFPROP CNVRUNINIT
 (LAMBDA NIL
  (MODCHR 100Q (MODCHR 47Q NIL))
  (DEFPROP QUOTE "@" PRINTMACRO)
  (REMLIST @(/! /, /: /!/" /@ /!' /!/, /!; /!< /!> /!? /!@) @PRINTMACRO)
  T)
 EXPR)

(DEFPROP CNVRCLEANUP
 (LAMBDA NIL
  (EXCISE)
  (REMOB CNVRINIT CNVRUNINIT CNVRCLEANUP)
  (GC)
  (DATA-INIT)
  (INITFN @(LAMBDA NIL
	    (MSG "CONNIVER")
	    (INITFN @CNVINT)
	    (ERR NIL)))
  T)
 EXPR)
)

(DEFPROP PP-!/"
 (LAMBDA (L) (APPLY# @CP-!/" L))
 EXPR)

(DEFPROP PP-MATCH
 (LAMBDA (L) (APPLY# @CP-MATCH L))
 EXPR)

(DEFPROP EDITC
 (LAMBDA (X)
  (PROG (L)
	(COND [(NULL X) (PRINT @=) (SETQ X (NCONS (PRIN1 LASTWORD)))])
	(COND [(CONSP (SETQ L (GET (CAR X) @CEXPR)))
	       (EDITE L (CDR X) (CAR X))
	       (RETURN (SETQ LASTWORD (CAR X)))]
	      [T (PRINT (CAR X)) (PRINC @"not editable.") (ERR NIL)])))
 FEXPR)

(DEFPROP EDITD
 (LAMBDA (X)
  (PROG (L)
	(COND [(NULL X) (PRINT @=) (SETQ X (NCONS (PRIN1 LASTWORD)))])
	(COND [(CONSP (SETQ L (GET (CAR X) @DATUM)))
	       (EDITE L (CDR X) (CAR X))
	       (RETURN (SETQ LASTWORD (CAR X)))]
	      [T (PRINT (CAR X)) (PRINC @"not editable.") (ERR NIL)])))
 FEXPR)

(DEFPROP DATA
 (LAMBDA NIL
  (PROG (X)
   LOOP (COND [(NULL (SETQ X (READ))) (RETURN NIL)]
	      [(ATOM X) (CREMOVE X) (ADD X)]
	      [(ATOM (CAR X)) (ADD (EVAL X))]
	      [T (ADD (CAR X))])
	(GO LOOP)))
 FEXPR)

(NOCOMPILE
(DEFV CNVRFNS ((DECLARE (DEFP **ARRAY *SUBR FSUBR)) (V: (INTERNSTR T)) 
	       (DEFP *DELETE DELETE FSUBR) (DEFP *ENTER ENTER SUBR) (REMOB 
	       DELETE ENTER) (DEFP VALUE EVAL LSUBR) (DECLARE (SPECIAL 
	       CSYSFNS DATUM CEXPRS OBLIST NEWFNS)) CDUMP CSYSFNS BOUNDP 
	       NEWFNS = > < + MAKREADTABLE (V: PRETTYPROPS) PI-OFF PI-ON 
	       SSTATUS DELQ DELETE (DECLARE (SPECIAL OBARRAY READTABLE 
	       ERRLIST BASE IBASE)) (DECLARE (SPECIAL *TOP UARGS BODY EARGS 
	       CHALOBV BVARS ALINK CLINK EXP FRAME* FREEVARS FRAMEVARS LEVNUM 
	       PC RUNF TEM TEM1 TYPE VAL VARS CINTERRUPT SERRLI ALLOW READY 
	       GLOBALS * ** ←) (*FEXPR CDEFGEN CDEFUN CERR CONNIVER CSETQ /: 
	       /@ /,) (*LEXPR MATCH ACCESS CONTROL CSET RVALUE VLOC RUN 
	       TRYASSIGN VALUE)) (V: (RUNF NIL) (SERRLI NIL) (** **) 
	       (GLOBALS ((NIL NIL) (T T))) (*TOP *TOP)) (*** THE FRAME FORMAT 
	       IS AS FOLLOWS ((IVARS . PC) (BVARS . ALINK) EXP . CLINK)) 
	       (V: (FREEVARS (VAL VARS UARGS BODY EARGS TEM TEM1 ALLOW)) 
	       (FRAMEVARS (CHALOBV FRAME* BVARS ALINK CLINK EXP CINTERRUPT 
	       READY))) BVARS ALINK EXP CLINK BODY (*** THE HACK REALLY 
	       BEGINS HERE -- RUN1 IS THE SYSTEM DRIVER) RUN RUN1 CAP HANDLE 
	       START STOP *STOP U-LOSE CERR EAR TOP CINTERRUPT ALLOW 
	       (*** DISPATCH IS THE "PUSHJ" FOR CONNIVER) (DECLARE (SPECIAL 
	       ALINK1 EXP1 RETAG SAVE)) DISPATCH SAVEUP SAVEV (*** FUNCTION 
	       CALLS RETURN VIA "POPJ") POPJ RESTORE REST1 (DECLARE (
	       UNSPECIAL ALINK1 EXP1 RETAG SAVE)) BIND1 CLOSE (*** MOBY 
	       BINDER -- NORMAL FUNCTION LISTS) ARGB ARGB1 ARGQ (*** BIND UP 
	       "OPTIONALs" AND "RESTs") OPTMATCH OPTMATCH1 RESTMATCH EVREST 
	       EVREST1 (*** WHEN RUN OUT OF ARGS BUT HAVE SOME "OPTIONALs" OR 
	       "RESTs") FINVAR FINVAR1 FINVAR2 FINVAR3 (*** BINDS "AUX" 
	       VARIABLES) AUXB AUXB1 AUXB2 CPROG PROG PROGBIND PROGB1 
	       (*** BASIC PROG ITERATION LOOP) LINE LINE1 (*** EVALUATES 
	       ARGUMENTS TO LISP EXPRS SUBRS AND LSUBRS) EVARGS ARGS1 
	       (*** LOGICAL FLOW OF CONTROL FUNCTIONS) CCOND CONDLP COND1 
	       COND IAND IAND1 AND IOR IOR1 OR (*** USERS OF FRAMES -- FLOW 
	       OF CONTROL CONTROLLERS) CGO GO1 GO CEXIT EXIT1 EXIT2 EXIT 
	       CRETURN RETURN1 RETURN CDISMISS DISMISS CONTINUE CONT1 CONT2 
	       (*** RELATIVE EVALUATORS) ICEVAL CEVAL1 CEVAL2 CEVAL ICALL 
	       CALL1 CALL INVOKE TRY1 TRY2 TEXT FR (*** IDENTIFIER 
	       MANIPULATORS) VFRAME VLOC RVALUE (DECLARE (SPECIAL ID)) IVAL 
	       (DECLARE (UNSPECIAL ID)) ICSETQ CSETQ0 CSETQ1 CSETQ CSET 
	       UNASSIGN (*** FRAME CONSTRUCTORS) CHAUX TAG ACTBLOCK ACCESS 
	       CONTROL CLOSURE FRAME (*** VERY DANGEROUS USER (HA!) FUNCTIONS) 
	       SETACCESS SETCONTROL (*** DEBUGGING AIDS) EXPRESSION BACKTRACE 
	       LISTENB LISTEN CONDB PROGB CEVALB UPDATEB UPDATE SETB SET 
	       PROGBINDB (*** USER INTERFACE) CDEFUN (DEFP CDE CDEFUN FSUBR) 
	       (NOCOMPILE (DEFP CDE CDEFUN FEXPR)) GENLEV /: /@ /! /, CPRIN1 
	       CPRINT CP-MACR CP-QUOTE QUOTE CP-*TAG *TAG *CLOSURE CP-*FRAME 
	       *FRAME *AU-REVOIR CP-MATCH /!' /!@ CP-!/" COLMAC COMMAC ATMAC 
	       EXMAC NXTCHR (DECLARE (SPECIAL CFRAMES CNUM CONTEXT DATUM 
	       CMARKERS TYPE PATTERN GLOBAL INCCON NUMACT NUMCON *CNUM 
	       *IF-ADDEDS *IF-NEEDEDS *IF-REMOVEDS *INDEXTHRESHOLD *ITEMS NEW) 
	       (*FEXPR /!/" CDEFUN CERR CSETQ /: /, GCCON IF-ADDED IF-NEEDED 
	       IF-REMOVED) (*LEXPR BIND ABSENT ADD CEVAL CFRAME CSET VLOC 
	       DGET DGET+ DPUT DPUT+ DREM DREM+ FETCH FETCHI FETCHM INSERT 
	       KILL MATCH NOTE OBJECT POP-CONTEXT PRESENT DATA-INIT 
	       PUSH-CONTEXT REAL REALIZE REMOVE RVALUE UNREAL UNREALIZE) 
	       (*EXPR ARGS DATUM CMARKERS PATTERN) (**ARRAY FRAMES RFRAMES) 
	       (CALL FRAMES RFRAMES)) (SETQ *INDEXTHRESHOLD 12Q) OBJECT TMA 
	       TFA (DECLARE (UNSPECIAL CMARKERS TYPE)) MAKE-METHOD (DECLARE 
	       (SPECIAL CMARKERS TYPE)) IF-NEEDED IF-ADDED IF-REMOVED 
	       DATA-INIT (DECLARE (UNSPECIAL PATTERN)) FETCH FETCHI FETCHM 
	       FETCHI1 FETCHM1 (DECLARE (SPECIAL PATTERN)) REAL UNREAL 
	       PRESENT ABSENT (DECLARE (UNSPECIAL PATTERN)) SEARCH (DECLARE 
	       (SPECIAL PATTERN)) REALITY REALITY1 DATUM ADD CREMOVE REMOVE 
	       INSERT KILL ACTUALIZE UNACTUALIZE (DECLARE (UNSPECIAL DATUM) 
	       (SPECIAL PAT CON)) REALIZE UNREALIZE (DECLARE (SPECIAL DATUM) 
	       (UNSPECIAL PAT CON)) CALLDEMONS RUNDAEMONS NXTMET REVEAL HIDE 
	       ADDCFRAME FINDCFRAME CANCEL MERGEN MERGE DPUTCF DGETCF DREMCF 
	       DPUT DGET DREM DPUT+ DGET+ DREM+ DPUT1 DGET1 DREM1 MENTIONERS 
	       (DECLARE (UNSPECIAL DATUM)) C-MARKER (DECLARE (SPECIAL DATUM)) 
	       MFINTERSECT (DECLARE (UNSPECIAL CMARKERS)) INVISIBLE (DECLARE 
	       (UNSPECIAL CFRAMES)) GETCONTEXT (DECLARE (UNSPECIAL PATTERN)) 
	       ISEARCH ISEARCH1 ASEARCH ASSQ1 (DECLARE (SPECIAL THING PFORM 
	       INDEX)) INDEX (DECLARE (UNSPECIAL PFORM INDEX)) UNINDEX 
	       (DECLARE (UNSPECIAL THING)) INDEX1 UNINDEX1 (DECLARE (SPECIAL 
	       PATTERN)) ANALYZE (DECLARE (UNSPECIAL PATTERN)) CMARKERS 
	       PATTERN DELTHING DELITEM MEMCAR FIRSTCAR< ITEM DATUMIZE 
	       ATOMIZE PUSH-CONTEXT POP-CONTEXT (DECLARE (UNSPECIAL CFRAMES)) 
	       NEW-CONTEXT (DECLARE (SPECIAL CFRAMES)) SPLICE (DECLARE 
	       (SPECIAL EXPR)) IN-CONTEXT (DECLARE (UNSPECIAL EXPR)) PATH 
	       (DECLARE (SPECIAL PATTERN)) FINALIZE (DECLARE (UNSPECIAL 
	       PATTERN)) CFRAME ORDERED NEWCNUM CNUMSINUSE *GCCON GCCON 
	       (DECLARE (SPECIAL PATTERN)) FLUSH (DECLARE (UNSPECIAL PATTERN)) 
	       REMCFRAME /!/" /!/"1 KTH (DECLARE (SPECIAL TEM TEM1 TEM2 ALINK 
	       BVARS EXP CLINK FRAME* VAL) (*FEXPR CERR INSTANCE PROPOSE /,) 
	       (*LEXPR CSET VFRAME ACCESS CONTROL)) ALINK CLINK TRY-NEXT NEXT 
	       SETUP GENGO METGO REGO TBLOCK UNBLOCK NOTE ADIEU AU-REVOIR 
	       ENTER PROPOSE INSTANCE CPY GET-POSSIBILITIES SET-POSSIBILITIES 
	       GENERATE (DECLARE (SPECIAL MALIST MALIST1 MALIST2 MALISTV1 
	       MALISTV2 NOBIND VALV) (*LEXPR MATCH TRYASSIGN RVALUE VLOC) 
	       (*FEXPR CERR)) MATCH (DECLARE (UNSPECIAL MALIST1 MALIST2)) 
	       MATCH1 (DECLARE (UNSPECIAL MALISTV2)) COMMA (DECLARE (
	       UNSPECIAL MALISTV1)) MATCH2 /!? /!> TRYASSIGN /!< /!; CHECKVAL 
	       (DECLARE (UNSPECIAL VALV)) FINDVARS HASMUSTASSIGNS HASVARS 
	       VARSUBST ACTOR ACTORSUBST GETSPEC MBIND MBINDV (DECLARE 
	       (UNSPECIAL NOBIND)) MBINDR /!/, /!/,1 SATISFY (DECLARE 
	       (UNSPECIAL MALIST)) MSET ASSIGNED? CNVINT (*PG*) (MBD: PROGN 
	       CNVRINIT CNVRUNINIT CNVRCLEANUP) PP-!/" PP-MATCH EDITC EDITD 
	       DATA))
)