perm filename DB.LSP[NET,GUE] blob sn#027749 filedate 1973-03-07 generic text, type T, neo UTF8
00100
00200	(GLOBAL (FUNCTIONS IN-CONTEXT
00300	 		   OBJECT
00400	 		   CFRAME
00500	 		   PUSH-CONTEXT
00600	 		   POP-CONTEXT
00700	 		   SPLICE
00800	 		   FETCHI
00900	 		   FETCHM
01000	 		   REALIZE
01100	 		   UNREALIZE
01200	 		   REAL
01300	 		   UNREAL
01400	 		   ACTUALIZE
01500	 		   UNACTUALIZE
01600	 		   DPUTCF
01700	 		   DGETCF
01800	 		   DREMCF
01900	 		   DPUT
02000	 		   DGET
02100	 		   DREM
02200	 		   DPUT+
02300	 		   DGET+
02400	 		   DREM+
02500	 		   PRESENT
02600	 		   ABSENT
02700	 		   DATUM
02800	 		   MENTIONERS
02900	 		   C-MARKER
03000	 		   !"
03100	 		   !"1
03200	 		   IF-NEEDED
03300	 		   IF-ADDED
03400	 		   IF-REMOVED
03500	 		   DATA-INIT
03600	 		   FETCH
03700	 		   ADD
03800	 		   REMOVE
03900	 		   INSERT
04000	 		   KILL
04100	 		   FLUSH
04200	 		   NEW-CONTEXT
04300	 		   PATH)
04400		(RESERVED *CONTEXT
04500	 		  DATUM
04600	 		  *CFRAME
04700	 		  GLOBAL
04800	 		  *OBJECT
04900	 		  *POSSIBILITIES
05000	 		  CONTEXT
05100	 		  *ITEM
05200	 		  *METHOD
05300	 		  *IGNORE))
05400
05500	(DECLARE (SYMBOLS T)
05600		 (GENPREFIX \D)
05700		 (GENSYM (QUOTE D))
05800		 (SPECIAL CFRAMES
05900	 		  CNUM
06000	 		  CONTEXT
06100	 		  DATUM
06200	 		  CMARKERS
06300	 		  TYPE
06400	 		  PATTERN
06500	 		  GLOBAL
06600	 		  INCCON
06700	 		  NUMACT
06800	 		  NUMCON
06900	 		  *CNUM
07000	 		  *IF-ADDEDS
07100	 		  *IF-NEEDEDS
07200	 		  *IF-REMOVEDS
07300	 		  *INDEXTHRESHOLD
07400	 		  *ITEMS
07500	 		  NEW)
07600		 (*FEXPR !"
07700	 		 CDEFUN
07800	 		 CERR
07900	 		 CSETQ
08000	 		 :
08100	 		 /,
08200	 		 GCCON
08300	 		 IF-ADDED
08400	 		 IF-NEEDED
08500	 		 IF-REMOVED)
08600		 (*LEXPR  DELQ DELETE BIND
08700	 		 ABSENT
08800	 		 ADD
08900	 		 CEVAL
09000	 		 CFRAME
09100	 		 CSET
09200	 		 VLOC
09300	 		 DGET
09400	 		 DGET+
09500	 		 DPUT
09600	 		 DPUT+
09700	 		 DREM
09800	 		 DREM+
09900	 		 FETCH
10000	 		 FETCHI
10100	 		 FETCHM
10200	 		 INSERT
10300	 		 KILL
10400	 		 MATCH
10500	 		 NOTE
10600	 		 OBJECT
10700	 		 POP-CONTEXT
10800	 		 PRESENT
10900	 		 DATA-INIT
11000	 		 PUSH-CONTEXT
11100	 		 REAL
11200	 		 REALIZE
11300	 		 REMOVE
11400	 		 RVALUE
11500	 		 UNREAL
11600	 		 UNREALIZE)
11700		 (*EXPR ARGS DATUM CMARKERS PATTERN)
11800		 (**ARRAY FRAMES RFRAMES))
11900
12000	(SETQ *INDEXTHRESHOLD 12)
12100
12200	(DEFPROP OBJECT
12300		 (LAMBDA N
12400		  (LIST (QUOTE *OBJECT)
12500			(COND ((= N 0) NIL) ((= N 1) (ARG 1)) ((TMA)))))
12600	 	 EXPR)
12700
12800	(DEFPROP TMA (LAMBDA NIL (CERR TOO MANY ARGUMENTS)) EXPR)
12900
13000	(DEFPROP TFA (LAMBDA NIL (CERR TOO FEW ARGUMENTS)) EXPR)
13100
13200	(DECLARE (UNSPECIAL CMARKERS TYPE))
13300
13400	(DEFPROP MAKE-METHOD
13500		 (LAMBDA(TYPE BOD)
13600		  (PROG (FIRST OLDM CMARKERS)
13700			(COND
13800			 ((ATOM (SETQ FIRST (CAR BOD)))
13900			  (SETQ CMARKERS
14000				(COND
14100				 ((SETQ OLDM (GET FIRST (QUOTE DATUM)))
14200				  (CDR (CMARKERS OLDM)))))
14300			  (PUTPROP FIRST
14400				   (NCONC (LIST TYPE
14500	 					FIRST
14600						(CADR BOD)
14700						(CDDR BOD))
14800	 				  CMARKERS)
14900				   (QUOTE DATUM))
15000			  (RETURN FIRST))
15100			 ((RETURN (LIST TYPE NIL FIRST (CDR BOD)))))))
15200	 	 EXPR)
15300
15400	(DECLARE (SPECIAL CMARKERS TYPE))
15500
15600	(DEFPROP IF-NEEDED
15700		 (LAMBDA (A) (MAKE-METHOD (QUOTE IF-NEEDED) A))
15800	 	 FEXPR)
15900
16000	(DEFPROP IF-ADDED
16100		 (LAMBDA (A) (MAKE-METHOD (QUOTE IF-ADDED) A))
16200	 	 FEXPR)
16300	(DEFPROP IF-REMOVED
16400		 (LAMBDA (A) (MAKE-METHOD (QUOTE IF-REMOVED) A))
16500	 	 FEXPR)
16600
16700	(DEFPROP DATA-INIT
16800		 (LAMBDA K
16900		  ((LAMBDA(N M)
17000		    (PROG NIL
17100			  (PI-OFF)
17200			  (COND
17300			   ((BOUNDP (QUOTE NUMACT))
17400			    (DO I
17500	 			0
17600				(ADD1 I)
17700				(= I NUMACT)
17800				(DO DATA
17900				    (CDDR (FRAMES I))
18000				    (CDR DATA)
18100				    (NULL DATA)
18200				    ((LAMBDA(D)
18300				      (AND (ATOM D)
18400					   (RPLACD (CMARKERS D) NIL)))
18500				     (CAR DATA))))))
18600			  (SETQ NUMCON N)
18700			  (SETQ INCCON M)
18800			  (ARRAY FRAMES T NUMCON)
18900			  (ARRAY RFRAMES T NUMCON)
19000			  (STORE (FRAMES 0)
19100				 (LIST (QUOTE *CFRAME) (SETQ *CNUM 0)))
19200			  (STORE (RFRAMES 0) (CDR (FRAMES 0)))
19300			  (CSETQ CONTEXT
19400				 (CSETQ GLOBAL
19500					(LIST (QUOTE *CONTEXT) (FRAMES 0))))
19600			  (SETQ NUMACT 1)
19700			  (PUTPROP (QUOTE ITEM)
19800				   (SETQ *ITEMS
19900					 (LIST (QUOTE *LIST)
20000					       (QUOTE (PATTERN THING))
20100	 				       0))
20200				   (QUOTE *INDEX))
20300			  (PUTPROP (QUOTE IF-NEEDED)
20400				   (SETQ *IF-NEEDEDS
20500					 (LIST (QUOTE *LIST)
20600					       (QUOTE (PATTERN THING))
20700	 				       0))
20800				   (QUOTE *INDEX))
20900			  (PUTPROP (QUOTE IF-ADDED)
21000				   (SETQ *IF-ADDEDS
21100					 (LIST (QUOTE *LIST)
21200					       (QUOTE (PATTERN THING))
21300	 				       0))
21400				   (QUOTE *INDEX))
21500			  (PUTPROP (QUOTE IF-REMOVED)
21600				   (SETQ *IF-REMOVEDS
21700					 (LIST (QUOTE *LIST)
21800					       (QUOTE (PATTERN THING))
21900	 				       0))
22000				   (QUOTE *INDEX))
22100			  (SSTATUS INTERRUPT 24 (QUOTE GCCON))
22200			  (RETURN (PI-ON))))
22300		   (COND ((> K 0) (ARG 1)) (T 144))
22400		   (COND ((> K 1) (ARG 2)) (T 12))))
22500	 	 EXPR)
22600
22700	(DECLARE (UNSPECIAL PATTERN))
22800
22900	(DEFPROP FETCH
23000		 (LAMBDA N
23100		  (PROG (PATTERN CON)
23200			(SETQ PATTERN (ARG 1))
23300			(SETQ CON (GETCONTEXT 1 N))
23400			(RETURN
23500			 (CONS (LIST (QUOTE *POSSIBILITIES) PATTERN)
23600			       (CONS (QUOTE *IGNORE)
23700				     (NCONC (FETCHI1 PATTERN CON)
23800					    (FETCHM1 PATTERN
23900	 					     *IF-NEEDEDS
24000	 					     CON)))))))
24100	 	 EXPR)
24200
24300	(DEFPROP FETCHI
24400		 (LAMBDA N
24500		  (CONS (LIST (QUOTE *POSSIBILITIES) (ARG 1))
24600			(CONS (QUOTE *IGNORE)
24700			      (FETCHI1 (ARG 1) (GETCONTEXT 1 N)))))
24800	 	 EXPR)
24900
25000	(DEFPROP FETCHM
25100		 (LAMBDA N
25200		  (PROG NIL
25300			(COND ((> N 3) (TMA)))
25400			(RETURN
25500			 ((LAMBDA(CON)
25600			   (CONS (LIST (QUOTE *POSSIBILITIES) (ARG 1))
25700				 (CONS (QUOTE *IGNORE)
25800				       (FETCHM1 (ARG 1)
25900						(COND
26000						 ((< N 2) *IF-NEEDEDS)
26100						 ((GET (ARG 2)
26200						       (QUOTE *INDEX))))
26300	 					CON))))
26400			  (COND ((< N 3) (/, CONTEXT)) ((ARG 3)))))))
26500	 	 EXPR)
26600
26650	(DECLARE(SPECIAL ALISTS PATTERN))
26700	(DEFPROP FETCHI1
26800		 (LAMBDA(PATTERN CON)
26900		  (PROG (ALISTS)
27000			(RETURN
27100			 (MAPCAN (QUOTE
27200				  (LAMBDA(ITEM)
27300				   (COND
27400				    ((SETQ ALISTS (MATCH PATTERN (CAR ITEM)))
27500				     (LIST
27600				      (LIST (QUOTE *ITEM)
27700	 				    ITEM
27800					    (CAR ALISTS)))))))
27900				 (SEARCH *ITEMS PATTERN T (CDR CON))))))
28000	 	 EXPR)
28100
28150	(DECLARE(UNSPECIAL ALISTS PATTERN))
28175	(DECLARE(SPECIAL METHOD PATTERN))
28200	(DEFPROP FETCHM1
28300		 (LAMBDA(PATTERN INDEX CON)
28400		  (MAPCAN (QUOTE
28500			   (LAMBDA(METHOD)
28600			    ((LAMBDA(MRESULT)
28700			      (COND
28800			       (MRESULT
28900				(LIST
29000				 (CONS (QUOTE *METHOD)
29100				       (CONS METHOD
29200					     (NCONC MRESULT
29300						    (LIST PATTERN))))))))
29400			     (MATCH (PATTERN METHOD) PATTERN))))
29500			  (SEARCH INDEX PATTERN NIL (CDR CON))))
29600	 	 EXPR)
29650	(DECLARE(UNSPECIAL METHOD PATTERN))
29700
29800	(DECLARE (SPECIAL PATTERN))
29900
30000	(DEFPROP REAL
30100		 (LAMBDA N (AND (REALITY (ARG 1) (GETCONTEXT 1 N)) (ARG 1)))
30200	 	 EXPR)
30300	(DEFPROP UNREAL
30400		 (LAMBDA N
30500		  (AND (NOT (REALITY (ARG 1) (GETCONTEXT 1 N))) (ARG 1)))
30600	 	 EXPR)
30700
30800	(DEFPROP PRESENT
30900		 (LAMBDA N
31000		  (PROG (CON PAT CANDIDATES ALISTS)
31100			(SETQ PAT (ARG 1))
31200			(SETQ CON (GETCONTEXT 1 N))
31300			(SETQ CANDIDATES (SEARCH *ITEMS PAT T (CDR CON)))
31400	 	   LOOP (COND ((NULL CANDIDATES) (RETURN NIL))
31500			      ((SETQ ALISTS
31600				     (MATCH PAT (ITEM (CAR CANDIDATES))))
31700			       (MAPC (QUOTE
31800				      (LAMBDA(PAIR)
31900				       (CSET (CAR PAIR) (CADR PAIR))))
32000				     (CAR ALISTS))
32100			       (RETURN (CAR CANDIDATES))))
32200			(SETQ CANDIDATES (CDR CANDIDATES))
32300			(GO LOOP)))
32400	 	 EXPR)
32500
32600	(DEFPROP ABSENT
32700		 (LAMBDA N (UNREAL (DATUM (ARG 1)) (GETCONTEXT 1 N)))
32800	 	 EXPR)
32900
33000	(DECLARE (UNSPECIAL PATTERN))
33100
33150	(DECLARE(SPECIAL  THING CON))
33200	(DEFPROP SEARCH
33300		 (LAMBDA(INDEX PATTERN ITEM CON)
33400		  (MAPCAN (QUOTE
33500			   (LAMBDA(THING)
33600			    (COND
33700			     ((REALITY1 (CDR (CMARKERS THING)) CON)
33800			      (LIST THING)))))
33900			  (ISEARCH INDEX PATTERN ITEM)))
34000	 	 EXPR)
34050	(DECLARE (UNSPECIAL THING CON))
34100
34200	(DECLARE (SPECIAL PATTERN))
34300
34400	(DEFPROP REALITY
34500		 (LAMBDA(DATUM CON)
34600		  (REALITY1 (CDR (CMARKERS DATUM)) (CDR CON)))
34700	 	 EXPR)
34800
34900	(DEFPROP REALITY1
35000		 (LAMBDA(CMARKERS CFRAMES)
35100		  (PROG (CM CON)
35200			(SETQ CON CFRAMES)
35300	 	   LOOP (COND
35400			 ((SETQ CM (MFINTERSECT))
35500			  (OR (INVISIBLE (CADR CM) CON) (RETURN CM))
35600			  (SETQ CMARKERS (CDR CMARKERS))
35700			  (SETQ CFRAMES (CDR CFRAMES))
35800			  (GO LOOP))
35900			 ((RETURN NIL)))))
36000	 	 EXPR)
36100
36200	(DEFPROP DATUM
36300		 (LAMBDA(SKELETON)
36400		  (PROG (CANDIDATES)
36500			(SETQ CANDIDATES (ISEARCH *ITEMS SKELETON T))
36600	 	   LOOP (COND
36700			 ((NULL CANDIDATES) (RETURN (LIST SKELETON)))
36800			 ((EQUAL (ITEM (CAR CANDIDATES)) SKELETON)
36900			  (RETURN (CAR CANDIDATES))))
37000			(SETQ CANDIDATES (CDR CANDIDATES))
37100			(GO LOOP)))
37200	 	 EXPR)
37300
37400	(DEFPROP ADD
37500		 (LAMBDA N (REALIZE (DATUMIZE (ARG 1)) (GETCONTEXT 1 N)))
37600	 	 EXPR)
37700	(CDEFUN ADD
37800		(THING "OPTIONAL" (CONTEXT CONTEXT))
37900		(REALIZE (@ DATUMIZE (/, THING)) CONTEXT))
38000
38100	(DEFPROP REMOVE
38200		 (LAMBDA N (UNREALIZE (DATUMIZE (ARG 1)) (GETCONTEXT 1 N)))
38300	 	 EXPR)
38400
38500	(CDEFUN REMOVE
38600		(THING "OPTIONAL" (CONTEXT CONTEXT))
38700		(UNREALIZE (@ DATUMIZE (/, THING)) CONTEXT))
38800
38900	(DEFPROP INSERT
39000		 (LAMBDA N
39100		  ((LAMBDA(D)
39200		    (PROG NIL (REVEAL D (GETCONTEXT 1 N)) (RETURN D)))
39300		   (DATUMIZE (ARG 1))))
39400	 	 EXPR)
39500
39600	(DEFPROP KILL
39700		 (LAMBDA N
39800		  ((LAMBDA(D)
39900		    (PROG NIL (HIDE D (GETCONTEXT 1 N)) (RETURN D)))
40000		   (DATUMIZE (ARG 1))))
40100	 	 EXPR)
40200
40300	(DEFPROP ACTUALIZE
40400		 (LAMBDA N
40500		  (PROG NIL
40600			(REVEAL (ARG 1) (GETCONTEXT 1 N))
40700			(RETURN (ARG 1))))
40800	 	 EXPR)
40900
41000	(DEFPROP UNACTUALIZE
41100		 (LAMBDA N
41200		  (PROG NIL
41300			(HIDE (ARG 1) (GETCONTEXT 1 N))
41400			(RETURN (ARG 1))))
41500	 	 EXPR)
41600
41700	(DECLARE (UNSPECIAL DATUM) (SPECIAL PAT CON))
41800
41900	(DEFPROP REALIZE
42000		 (LAMBDA N
42100		  (PROG (DATUM CON PAT)
42200			(SETQ DATUM (ARG 1))
42300			(SETQ CON (GETCONTEXT 1 N))
42400			(COND
42500			 ((AND (REVEAL DATUM CON) (SETQ PAT (ITEM DATUM)))
42600			  (CEVAL
42700			   (QUOTE
42800			    (CALLDEMONS (@ . PAT)
42900					(@ . *IF-ADDEDS)
43000					(@ . CON))))))
43100			(RETURN DATUM)))
43200	 	 EXPR)
43300
43400	(CDEFUN REALIZE
43500		(DATUM "OPTIONAL" (CONTEXT CONTEXT))
43600	        "AUX"
43700		(PAT)
43800		(COND
43900		 ((@ AND
44000		     (REVEAL (/, DATUM) (/, CONTEXT))
44100		     (CSETQ PAT (ITEM (/, DATUM))))
44200		  (CALLDEMONS PAT (@ . *IF-ADDEDS) CONTEXT)))
44300	        DATUM)
44400	(DEFPROP UNREALIZE
44500		 (LAMBDA N
44600		  (PROG (DATUM CON PAT)
44700			(SETQ DATUM (ARG 1))
44800			(SETQ CON (GETCONTEXT 1 N))
44900			(COND
45000			 ((AND (HIDE DATUM CON) (SETQ PAT (ITEM DATUM)))
45100			  (CEVAL
45200			   (QUOTE
45300			    (CALLDEMONS (@ . PAT)
45400					(@ . *IF-REMOVEDS)
45500					(@ . CON))))))
45600			(RETURN DATUM)))
45700	 	 EXPR)
45800
45900	(CDEFUN UNREALIZE
46000		(DATUM "OPTIONAL" (CONTEXT CONTEXT))
46100	        "AUX"
46200		(PAT)
46300		(COND
46400		 ((@ AND
46500		     (HIDE (/, DATUM) (/, CONTEXT))
46600		     (CSETQ PAT (ITEM (/, DATUM))))
46700		  (CALLDEMONS PAT (@ . *IF-REMOVEDS) CONTEXT)))
46800	        DATUM)
46900
47000	(DECLARE (SPECIAL DATUM) (UNSPECIAL PAT CON))
47100
47200	(DEFPROP CALLDEMONS
47300		 (LAMBDA(PAT INDEX CONTEXT)
47400		  (CINTERRUPT
47500		   (LIST (QUOTE RUNDAEMONS)
47600	 		 PAT
47700	 		 CONTEXT
47800			 (SEARCH INDEX PAT NIL (CDR CONTEXT)))))
47900	 	 EXPR)
48000
48100	(CDEFUN RUNDAEMONS
48200		((QUOTE PAT) (QUOTE CONTEXT) (QUOTE METS))
48300		(ALLOW T)
48400		(: TLP)
48500		(COND (METS (INVOKE (NXTMET) PAT) (GO (QUOTE TLP)))))
48600
48700	(DEFPROP NXTMET
48800		 (LAMBDA(L)
48900		  (PROG2 (SETQ L (CDR (VLOC (QUOTE METS))))
49000			 (CAAR L)
49100			 (RPLACA L (CDAR L))))
49200	 	 FEXPR)
49300
49400	(DEFPROP REVEAL
49500		 (LAMBDA(DATUM CON)
49600		  (PROG (CM STATUS
49700	 		    CMARKERS
49800	 		    CFRAMES
49900	 		    PATTERN
50000	 		    CNUM
50100	 		    CFRAME
50200	 		    NEW
50300	 		    TYPE
50400	 		    NUM)
50500			(PI-OFF)
50600			(SETQ CMARKERS (ANALYZE DATUM))
50700			(SETQ CFRAMES (SETQ CON (CDR CON)))
50800			(SETQ CM
50900			      (ADDCFRAME (SETQ CFRAME (CAR CON)) CMARKERS))
51000			(SETQ CNUM (CADR CFRAME))
51100			(SETQ STATUS (CADR CM))
51200			(RPLACA (CDR CM) (QUOTE /+))
51300			(COND (STATUS (PI-ON) (RETURN NIL))
51400			      ((AND PATTERN NEW (NULL (CDDR CMARKERS)))
51500			       (INDEX DATUM
51600	 			      PATTERN
51700				      (GET TYPE (QUOTE *INDEX)))))
51800			(SETQ CMARKERS (CDDR CMARKERS))
51900			(SETQ CFRAMES (CDR CFRAMES))
52000	 	   LOOP (COND
52100			 ((SETQ CM (MFINTERSECT))
52200			  (COND
52300			   ((SETQ NUM (INVISIBLE (CADR CM) CON))
52400			    (COND
52500			     ((EQUAL CNUM NUM) (SETQ NEW NIL)
52600					       (RPLACA
52700						(CDR CM)
52800						(OR
52900						 (DELETE CNUM (CADR CM) 1)
53000						 (QUOTE /+))))))
53100			   ((SETQ STATUS T)))
53200			  (SETQ CMARKERS (CDR CMARKERS))
53300			  (SETQ CFRAMES (CDR CFRAMES))
53400			  (GO LOOP))
53500			 (NEW
53600			  (RPLACD (CDR CFRAME) (CONS DATUM (CDDR CFRAME)))))
53700			(PI-ON)
53800			(RETURN (NOT STATUS))))
53900	 	 EXPR)
54000
54100	(DEFPROP HIDE
54200		 (LAMBDA(DATUM CON)
54300		  (PROG (PATTERN CFRAMES
54400	 			 CMARKERS
54500	 			 CNUM
54600	 			 STATUS
54700	 			 NUM
54800	 			 TYPE
54900	 			 REM
55000	 			 OLD
55100	 			 CFRAME
55200	 			 CM)
55300			(SETQ CFRAMES (SETQ CON (CDR CON)))
55400			(SETQ CMARKERS (ANALYZE DATUM))
55500			(SETQ CNUM (CADAR CON))
55600			(PI-OFF)
55700			(COND
55800			 ((SETQ CM
55900				(FINDCFRAME (SETQ CFRAME (CAR CFRAMES))
56000					    (CDR CMARKERS)))
56100			  (SETQ STATUS (CADR CM))
56200			  (SETQ OLD T)
56300			  (COND ((CDDR CM) (RPLACA (CDR CM) NIL))
56400				((SETQ REM T) (DELQ CM CMARKERS 1)
56500					      (AND PATTERN
56600						   (NULL (CDR CMARKERS))
56700						   (UNINDEX
56800						    DATUM
56900						    PATTERN
57000						    (GET TYPE (QUOTE *INDEX))
57100						    (EQ TYPE
57200							(QUOTE ITEM))))))))
57300			(SETQ CMARKERS (CDR CMARKERS))
57400	 	   LOOP (COND
57500			 ((SETQ CM (MFINTERSECT))
57600			  (COND
57700			   ((SETQ NUM (INVISIBLE (CADR CM) CON))
57800			    (COND (REM (SETQ REM (NOT (EQUAL CNUM NUM))))
57900				  ((OR OLD (SETQ OLD (EQUAL CNUM NUM))))))
58000			   (T(SETQ REM NIL) (SETQ STATUS T) (CANCEL CM CNUM)))
58100			  (SETQ CMARKERS (CDR CMARKERS))
58200			  (SETQ CFRAMES (CDR CFRAMES))
58300			  (GO LOOP))
58400			 (REM
58500			  (RPLACD (CDR CFRAME) (DELQ DATUM (CDDR CFRAME) 1)))
58600			 ((AND STATUS (NOT OLD))
58700			  (RPLACD (CDR CFRAME) (CONS DATUM (CDDR CFRAME)))))
58800			(PI-ON)
58900			(RETURN STATUS)))
59000	 	 EXPR)
59100
59200	(DEFPROP ADDCFRAME
59300		 (LAMBDA(CFRAME CMARKERS)
59400		  (PROG (N)
59500			(SETQ N (CADR CFRAME))
59600	 	   LOOP (COND
59700			 ((OR (NULL (CDR CMARKERS))
59800			      (LESSP (CAADR CMARKERS) N))
59900			  (RPLACD CMARKERS
60000				  (CONS (LIST N NIL) (CDR CMARKERS)))
60100			  (SETQ NEW T))
60200			 ((EQ N (CAADR CMARKERS)))
60300			 (T (SETQ CMARKERS (CDR CMARKERS)) (GO LOOP)))
60400			(RETURN (CADR CMARKERS))))
60500	 	 EXPR)
60600
60700	(DEFPROP FINDCFRAME
60800		 (LAMBDA(CFRAME CMARKERS)
60900		  (PROG (NF NM)
61000			(SETQ NF (CADR CFRAME))
61100	 	   LOOP (COND ((NULL CMARKERS) (RETURN NIL))
61200			      ((> NF (SETQ NM (CAAR CMARKERS))) (RETURN NIL))
61300			      ((> NM NF) (SETQ CMARKERS (CDR CMARKERS))
61400					 (GO LOOP))
61500			      ((RETURN (CAR CMARKERS))))))
61600	 	 EXPR)
61700	(DEFPROP CANCEL
61800		 (LAMBDA (CM NUM) (RPLACA (CDR CM) (MERGEN NUM (CADR CM))))
61900	 	 EXPR)
62000
62100	(DEFPROP MERGEN
62200		 (LAMBDA(N NL)
62300		  (COND ((ATOM NL) (LIST N))
62400			((> N (CAR NL)) (CONS N NL))
62500			((RPLACD NL (MERGEN N (CDR NL))))))
62600	 	 EXPR)
62700
62800	(DEFPROP DPUTCF
62900		 (LAMBDA(DATUM PROPERTY INDICATOR CFRAME)
63000		  (PROG (PATTERN TYPE CM TAIL NEW)
63100			(PI-OFF)
63200			(SETQ TAIL (ANALYZE DATUM))
63300			(SETQ CM (ADDCFRAME CFRAME TAIL))
63400			(COND
63500			 (NEW (RPLACD (CDR CFRAME)
63600				      (CONS DATUM (CDDR CFRAME)))
63700			      (AND PATTERN
63800				   (NULL (CDDR TAIL))
63900				   (INDEX DATUM
64000	 				  PATTERN
64100					  (GET TYPE (QUOTE *INDEX))))))
64200			(PI-ON)
64300			(RETURN (DPUT1 CM PROPERTY INDICATOR))))
64400	 	 EXPR)
64500
64600	(DEFPROP DGETCF
64700		 (LAMBDA(DATUM INDICATOR CFRAME)
64800		  (ASSQ INDICATOR
64900			(FINDCFRAME CFRAME (CDR (CMARKERS DATUM)))))
65000	 	 EXPR)
65100
65200	(DEFPROP DREMCF
65300		 (LAMBDA(DATUM INDICATOR CFRAME)
65400		  (PROG (CMARKERS PATTERN TYPE CM PAIR)
65500			(SETQ CMARKERS (ANALYZE DATUM))
65600			(SETQ CM (FINDCFRAME CFRAME (CDR CMARKERS)))
65700			(COND
65800			 ((AND CM (SETQ PAIR (ASSQ INDICATOR (CDDR CM))))
65900			  (PI-OFF)
66000			  (DELQ PAIR (CDR CM) 1)
66100			  (COND
66200			   ((NOT (OR (CADR CM) (CDDR CM)))
66300			    (DELQ CM CMARKERS 1)
66400			    (DELQ DATUM CFRAME 1)))
66500			  (COND
66600			   ((AND PATTERN (NULL (CDR CMARKERS)))
66700			    (UNINDEX DATUM
66800	 			     PATTERN
66900				     (GET TYPE (QUOTE *INDEX))
67000				     (EQ TYPE (QUOTE ITEM)))))
67100			  (PI-ON)
67200			  (RETURN PAIR)))))
67300	 	 EXPR)
67400
67500	(DEFPROP DPUT
67600		 (LAMBDA N
67700		  (DPUTCF (ARG 1) (ARG 2) (ARG 3) (CADR (GETCONTEXT 3 N))))
67800	 	 EXPR)
67900
68000	(DEFPROP DGET
68100		 (LAMBDA N
68200		  ((LAMBDA(CONTEXT)
68300		    (DGET1 (CDR (CMARKERS (ARG 1)))
68400			   (ARG 2)
68500			   (CDR CONTEXT)
68600	 		   NIL))
68700		   (GETCONTEXT 2 N)))
68800	 	 EXPR)
68900
69000	(DEFPROP DREM
69100		 (LAMBDA N
69200		  (DREM1 (ARG 1) (ARG 2) (CDR (GETCONTEXT 2 N)) NIL))
69300	 	 EXPR)
69400
69500	(DEFPROP DPUT+
69600		 (LAMBDA N
69700		  ((LAMBDA(CM)
69800		    (COND (CM (DPUT1 CM (ARG 2) (ARG 3)))
69900			  ((CERR ABSENT DATUM))))
70000		   (REALITY (ARG 1) (GETCONTEXT 3 N))))
70100	 	 EXPR)
70200
70300	(DEFPROP DGET+
70400		 (LAMBDA N
70500		  (DGET1 (CDR (CMARKERS (ARG 1)))
70600			 (ARG 2)
70700			 (CDR (GETCONTEXT 2 N))
70800	 		 T))
70900	 	 EXPR)
71000	(DEFPROP DREM+
71100		 (LAMBDA N (DREM1 (ARG 1) (ARG 2) (CDR (GETCONTEXT 2 N)) T))
71200	 	 EXPR)
71300
71400	(DEFPROP DPUT1
71500		 (LAMBDA(CM PROPERTY INDICATOR)
71600		  (PROG (PAIR)
71700			(COND
71800			 ((SETQ PAIR (ASSQ INDICATOR (CDDR CM)))
71900			  (RPLACA (CDR PAIR) PROPERTY))
72000			 ((RPLACD (CDR CM)
72100				  (CONS (SETQ PAIR (LIST INDICATOR PROPERTY))
72200					(CDDR CM)))))
72300			(RETURN PAIR)))
72400	 	 EXPR)
72500
72600	(DEFPROP DGET1
72700		 (LAMBDA(CMARKERS INDICATOR CFRAMES SIGN)
72800		  (PROG (PAIR CM CON)
72900			(SETQ CON CFRAMES)
73000	 	   LOOP (COND
73100			 ((NULL (SETQ CM (MFINTERSECT))) (RETURN NIL))
73200			 ((AND SIGN (INVISIBLE (CADR CM) CON)))
73300			 ((SETQ PAIR (ASSQ INDICATOR (CDDR CM)))
73400			  (RETURN PAIR)))
73500			(SETQ CMARKERS (CDR CMARKERS))
73600			(SETQ CFRAMES (CDR CFRAMES))
73700			(GO LOOP)))
73800	 	 EXPR)
73900
74000	(DEFPROP DREM1
74100		 (LAMBDA(DATUM INDICATOR CFRAMES SIGN)
74200		  (PROG (PAIR CMARKERS TAIL PATTERN TYPE CM CON)
74300			(SETQ CON CFRAMES)
74400			(SETQ CMARKERS (CDR (SETQ TAIL (ANALYZE DATUM))))
74500	 	   LOOP (COND
74600			 ((NULL (SETQ CM (MFINTERSECT))) (RETURN NIL))
74700			 ((AND SIGN (INVISIBLE (CADR CM) CON)))
74800			 ((SETQ PAIR (ASSQ INDICATOR (CDDR CM)))
74900			  (PI-OFF)
75000			  (DELQ PAIR (CDR CM))
75100			  (COND
75200			   ((NOT (OR (CADR CM) (CDDR CM)))
75300			    (DELQ CM TAIL)
75400			    (DELQ DATUM (CAR CFRAMES))))
75500			  (COND
75600			   ((AND PATTERN (NULL (CDR TAIL)))
75700			    (UNINDEX DATUM
75800	 			     PATTERN
75900				     (GET TYPE (QUOTE *INDEX))
76000				     (EQ TYPE (QUOTE ITEM)))))
76100			  (PI-ON)
76200			  (RETURN PAIR)))
76300			(SETQ CMARKERS (CDR CMARKERS))
76400			(SETQ CFRAMES (CDR CFRAMES))
76500			(GO LOOP)))
76600	 	 EXPR)
76700
76800	(DEFPROP MENTIONERS
76900		 (LAMBDA N
77000		  (PROG (CFRAMES CMARKERS MENTIONERS SIGN CM CON)
77100			(COND ((< N 1) (TFA)))
77200			(SETQ CFRAMES
77300			      (CDR
77400			       (COND ((< N 3) (/, CONTEXT))
77500				     ((= N 3) (ARG 3))
77600				     ((TMA)))))
77700			(SETQ SIGN (COND ((> N 1) (ARG 2))))
77800			(SETQ CMARKERS (CDR (CMARKERS (ARG 1))))
77900			(SETQ CON CFRAMES)
78000	 	   LOOP (COND
78100			 ((SETQ CM (MFINTERSECT))
78200			  (OR (AND SIGN (INVISIBLE (CADR CM) CON))
78300			      (SETQ MENTIONERS
78400				    (CONS (CAR CFRAMES) MENTIONERS)))
78500			  (SETQ CFRAMES (CDR CFRAMES))
78600			  (SETQ CMARKERS (CDR CMARKERS))
78700			  (GO LOOP)))
78800			(RETURN (REVERSE MENTIONERS))))
78900	 	 EXPR)
79000
79100	(DECLARE (UNSPECIAL DATUM))
79200
79300	(DEFPROP C-MARKER
79400		 (LAMBDA(DATUM CFRAME)
79500		  (FINDCFRAME CFRAME (CDR (CMARKERS DATUM))))
79600	 	 EXPR)
79700
79800	(DECLARE (SPECIAL DATUM))
79900
80000	(DEFPROP MFINTERSECT
80100		 (LAMBDA NIL
80200		  (PROG (NM NF CM)
80300	 	   ADVANCE
80400			(COND
80500			 ((AND CMARKERS CFRAMES) (SETQ NF (CADAR CFRAMES))
80600						 (SETQ CM (CAR CMARKERS))
80700						 (SETQ NM (CAR CM)))
80800			 ((RETURN NIL)))
80900	 	   TEST (COND ((> NF NM) (OR (SETQ CFRAMES (CDR CFRAMES))
81000					     (RETURN NIL))
81100					 (SETQ NF (CADAR CFRAMES))
81200					 (GO TEST))
81300			      ((> NM NF) (OR (SETQ CMARKERS (CDR CMARKERS))
81400					     (RETURN NIL))
81500					 (SETQ CM (CAR CMARKERS))
81600					 (SETQ NM (CAR CM))
81700					 (GO TEST))
81800			      ((RETURN CM)))))
81900	 	 EXPR)
82000
82100	(DECLARE (UNSPECIAL CMARKERS))
82200	(DEFPROP INVISIBLE
82300		 (LAMBDA(CNUMS CFRAMES)
82400		  (AND (NOT (EQ CNUMS (QUOTE /+)))
82500		       (OR (NULL CNUMS)
82600			   (PROG (NC NF)
82700				 (SETQ NC (CAR CNUMS))
82800	 		    LOOP (COND (CFRAMES (SETQ NF (CADAR CFRAMES))
82900						(SETQ CFRAMES (CDR CFRAMES)))
83000				       ((RETURN NIL)))
83100	 		    TEST (COND ((> NF NC) (GO LOOP))
83200				       ((> NC NF)
83300					(OR (SETQ CNUMS (CDR CNUMS))
83400					    (RETURN NIL))
83500					(SETQ NC (CAR CNUMS))
83600					(GO TEST))
83700				       ((RETURN NC)))))))
83800	 	 EXPR)
83900
84000	(DECLARE (UNSPECIAL CFRAMES))
84100
84200	(DEFPROP GETCONTEXT
84300		 (LAMBDA(K N)
84400		  (COND ((< N K) (TFA))
84500			((= N K) (/, CONTEXT))
84600			((= N (SETQ K (ADD1 K))) (ARG K))
84700			((TMA))))
84800	 	 EXPR)
84900
85000	(DECLARE (UNSPECIAL PATTERN))
85100
85200	(DEFPROP ISEARCH
85300		 (LAMBDA(INDEX PATTERN ITEM)
85400		  (APPLY (QUOTE APPEND) (CDR (ISEARCH1 INDEX PATTERN ITEM))))
85500	 	 EXPR)
85600
85700	(DEFPROP ISEARCH1
85800		 (LAMBDA(INDEX PATTERN ITEM)
85900		  (PROG (ASCAR ASCDR)
86000			(COND ((NULL INDEX) (RETURN (LIST 0)))
86100			      ((EQ (CAR INDEX) (QUOTE *LIST))
86200			       (RETURN
86300				(CONS (CADDR INDEX) (LIST (CDDDR INDEX)))))
86400			      ((EQ (CAR INDEX) (QUOTE *INDEX)))
86500			      (T (BREAK BAD-STRUCTURE-INDEX--ISEARCH T)))
86600			(RETURN
86700			 (COND
86800			  ((OR (ZEROP
86900				(CAR
87000				 (SETQ ASCAR
87100				       (ASEARCH (CADDR INDEX)
87200						(CAR PATTERN)
87300	 					ITEM))))
87400			       (NULL (CDR PATTERN))
87500			       (> (CAR
87600				   (SETQ ASCDR
87700					 (ASEARCH
87800					  (CDDDR INDEX)
87900					  (CDR PATTERN)
88000					  ITEM)))
88100				  (CAR ASCAR)))
88200			   ASCAR)
88300			  (ASCDR)))))
88400	 	 EXPR)
88500
88600	(DEFPROP ASEARCH
88700		 (LAMBDA(SUBINDEX ELEMENT ITEM)
88800		  (PROG (INDICATOR ASSOCIATION CLLIST VLIST)
88900			(COND
89000			 ((EQ (SETQ INDICATOR (ATOMIZE ELEMENT))
89100			      (QUOTE *VARIABLE))
89200			  (RETURN (LIST 10000))))
89300			(SETQ CLLIST
89400			      (COND
89500			       ((EQ INDICATOR (QUOTE *STRUCTURE))
89600				(ISEARCH1 (CAR SUBINDEX) ELEMENT ITEM))
89700			       ((SETQ ASSOCIATION
89800				      (ASSQ1 INDICATOR (CDR SUBINDEX)))
89900				(CONS (CADR ASSOCIATION)
90000				      (LIST (CDDR ASSOCIATION))))
90100			       ((LIST 0))))
90200			(COND
90300			 ((AND (NOT ITEM)
90400			       (SETQ ASSOCIATION
90500				     (ASSQ (QUOTE *VARIABLE) (CDR SUBINDEX)))
90600			       (SETQ VLIST (CDDR ASSOCIATION)))
90700			  (RPLACA CLLIST
90800				  (/+ (CAR CLLIST) (CADR ASSOCIATION)))
90900			  (RPLACD CLLIST (CONS VLIST (CDR CLLIST)))))
91000			(RETURN CLLIST)))
91100	 	 EXPR)
91200
91300	(DEFPROP ASSQ1
91400		 (LAMBDA(IND ALIST)
91500		  (COND ((NUMBERP IND) (ASSOC IND ALIST))
91600			((ASSQ IND ALIST))))
91700	 	 EXPR)
91800
91900	(DECLARE (SPECIAL THING PFORM INDEX))
92000
92100	(DEFPROP INDEX
92200		 (LAMBDA(THING PATTERN INDEX)
92300		  (PROG (NUM THINGS PFORM)
92400			(COND
92500			 ((NULL INDEX) (BREAK BAD-INDEX--INDEX T))
92600			 ((EQ (CAR INDEX) (QUOTE *LIST))
92700			  (COND
92800			   ((EQUAL (SETQ NUM (ADD1 (CADDR INDEX)))
92900	 			   *INDEXTHRESHOLD)
93000			    (RPLACA INDEX (QUOTE *INDEX))
93100			    (SETQ THINGS (CDDDR INDEX))
93200			    (SETQ PFORM (CADR INDEX))
93300			    (RPLACD (CDR INDEX) (LIST (LIST NIL) NIL))
93400			    (MAPC (!" LAMBDA
93500				      (THING)
93600				      (INDEX THING (@ . PFORM) INDEX))
93700	 			  THINGS))
93800			   (T (RPLACD (CDR INDEX)
93900				      (CONS NUM (CONS THING (CDDDR INDEX))))
94000			      (RETURN THING))))
94100			 ((EQ (CAR INDEX) (QUOTE *INDEX))
94200			  (SETQ PFORM (CADR INDEX)))
94300			 ((BREAK BAD-INDEX--INDEX T)))
94400			(INDEX1 THING
94500				(CAR PATTERN)
94600				(CADDR INDEX)
94700				(QUOTE CAR)
94800	 			PFORM)
94900			(AND (CDR PATTERN)
95000			     (INDEX1 THING
95100				     (CDR PATTERN)
95200				     (CDDDR INDEX)
95300				     (QUOTE CDR)
95400	 			     PFORM))
95500			(RETURN THING)))
95600	 	 EXPR)
95700	(DECLARE (UNSPECIAL PFORM INDEX))
95800
95900	(DEFPROP UNINDEX
96000		 (LAMBDA(THING PATTERN INDEX ITEM)
96100		  (COND
96200		   ((NULL INDEX) (BREAK BAD-INDEX--UNINDEX T))
96300		   ((EQ (CAR INDEX) (QUOTE *LIST))
96400		    (RPLACD (CDR INDEX)
96500			    (CONS (SUB1 (CADDR INDEX))
96600				  (DELTHING THING (CDDDR INDEX) ITEM)))
96700		    THING)
96800		   ((EQ (CAR INDEX) (QUOTE *INDEX))
96900		    (UNINDEX1 THING (CAR PATTERN) (CADDR INDEX) ITEM)
97000		    (AND (CDR PATTERN)
97100			 (UNINDEX1 THING (CDR PATTERN) (CDDDR INDEX) ITEM))
97200		    THING)
97300		   ((BREAK BAD-INDEX--UNINDEX T))))
97400	 	 EXPR)
97500
97600	(DECLARE (UNSPECIAL THING))
97700
97800	(DEFPROP INDEX1
97900		 (LAMBDA(THING ELEMENT SUBINDEX POS PFORM)
98000		  (PROG (INDICATOR ASSOCIATION)
98100			(COND
98200			 ((EQ (SETQ INDICATOR (ATOMIZE ELEMENT))
98300			      (QUOTE *STRUCTURE))
98400			  (COND
98500			   ((NULL (CAR SUBINDEX))
98600			    (RPLACA SUBINDEX
98700				    (LIST (QUOTE *LIST)
98800					  (LIST POS PFORM)
98900	 				  0))))
99000			  (INDEX THING ELEMENT (CAR SUBINDEX)))
99100			 ((SETQ ASSOCIATION (ASSQ1 INDICATOR (CDR SUBINDEX)))
99200			  (RPLACD ASSOCIATION
99300				  (CONS
99400				   (ADD1 (CADR ASSOCIATION))
99500				   (CONS THING (CDDR ASSOCIATION)))))
99600			 (T
99700			  (RPLACD SUBINDEX
99800				  (CONS (LIST INDICATOR 1 THING)
99900					(CDR SUBINDEX)))))))
     

00100	 	 EXPR)
00200
00300	(DEFPROP UNINDEX1
00400		 (LAMBDA(THING ELEMENT SUBINDEX ITEM)
00500		  (PROG (ASSOCIATION INDICATOR NUM)
00600			(SETQ INDICATOR (ATOMIZE ELEMENT))
00700			(COND
00800			 ((EQ INDICATOR (QUOTE *STRUCTURE))
00900			  (UNINDEX THING ELEMENT (CAR SUBINDEX) ITEM))
01000			 ((SETQ ASSOCIATION (ASSQ1 INDICATOR (CDR SUBINDEX)))
01100			  (COND
01200			   ((ZEROP (SETQ NUM (SUB1 (CADR ASSOCIATION))))
01300			    (DELQ ASSOCIATION SUBINDEX))
01400			   (T
01500			    (RPLACD ASSOCIATION
01600				    (CONS NUM
01700					  (DELTHING THING
01800						    (CDDR ASSOCIATION)
01900	 					    ITEM)))))))))
02000	 	 EXPR)
02100
02200	(DECLARE (SPECIAL PATTERN))
02300
02400	(DEFPROP ANALYZE
02500		 (LAMBDA(X)
02600		  (COND ((NULL X) (CERR MEANINGLESS DATUM _ _ ANALYZE))
02700			((ATOM X) (ANALYZE (GET X (QUOTE DATUM))))
02800			((EQ (CAR X) (QUOTE *CLOSURE))
02900			 (PROG2 (ANALYZE (CADR X)) (CDDR X) (SETQ DATUM X)))
03000			((EQ (CAR X) (QUOTE *OBJECT))
03100			 (SETQ PATTERN NIL)
03200			 (SETQ TYPE (QUOTE OBJECT))
03300			 (CDR X))
03400			((ATOM (SETQ TYPE (CAR X)))
03500			 (SETQ PATTERN (CADDR X))
03600			 (AND (CADR X) (SETQ DATUM (CADR X)))
03700			 (CDDDR X))
03800			(T (SETQ PATTERN (CAR X))
03900			   (SETQ TYPE (QUOTE ITEM))
04000	 		   X)))
04100	 	 EXPR)
04200
04300	(DECLARE (UNSPECIAL PATTERN))
04400
04500	(DEFPROP CMARKERS
04600		 (LAMBDA(DATUM)
04700		  (COND ((NULL DATUM) (CERR MEANINGLESS DATUM _ _ CMARKERS))
04800			((ATOM DATUM) (CMARKERS (GET DATUM (QUOTE DATUM))))
04900			((EQ (CAR DATUM) (QUOTE *CLOSURE)) (CDDR DATUM))
05000			((EQ (CAR DATUM) (QUOTE *OBJECT)) (CDR DATUM))
05100			((ATOM (CAR DATUM)) (CDDDR DATUM))
05200			(DATUM)))
05300	 	 EXPR)
05400
05500	(DEFPROP PATTERN
05600		 (LAMBDA(DATUM)
05700		  (COND ((NULL DATUM) (CERR MEANINGLESS DATUM _ _ PATTERN))
05800			((ATOM DATUM) (PATTERN (GET DATUM (QUOTE DATUM))))
05900			((EQ (CAR DATUM) (QUOTE *CLOSURE))
06000			 (PATTERN (CADR DATUM)))
06100			((ATOM (CAR DATUM)) (CADDR DATUM))
06200			((CAR DATUM))))
06300	 	 EXPR)
06400	(DEFPROP NTH
06500		 (LAMBDA(EXP N)
06600		  (COND ((= N 1) (CAR EXP)) ((NTH (CDR EXP) (SUB1 N)))))
06700	 	 EXPR)
06800
06900	(DEFPROP DELTHING
07000		 (LAMBDA(THING LIST ITEM)
07100		  (COND (ITEM (DELITEM (ITEM THING) LIST))
07200			((DELQ THING LIST 1))))
07300	 	 EXPR)
07400
07500	(DEFPROP DELITEM
07600		 (LAMBDA(EXP LIST)
07700		  (COND ((NULL LIST) NIL)
07800			((EQUAL EXP (ITEM (CAR LIST))) (CDR LIST))
07900			(T (RPLACD LIST (DELITEM EXP (CDR LIST))))))
08000	 	 EXPR)
08100
08200	(DEFPROP MEMCAR
08300		 (LAMBDA(EXP LIST)
08400		  (COND ((NULL LIST) NIL)
08500			((EQUAL EXP (ITEM (CAR LIST))) LIST)
08600			(T (MEMCAR EXP (CDR LIST)))))
08700	 	 EXPR)
08800
08900	(DEFPROP ITEM
09000		 (LAMBDA(DATUM)
09100		  (COND ((NULL DATUM) (CERR MEANINGLESS DATUM))
09200			((ATOM DATUM) (ITEM (GET DATUM (QUOTE DATUM))))
09300			(((LAMBDA (PAT) (AND (NOT (ATOM PAT)) PAT))
09400			  (CAR DATUM)))))
09500	 	 EXPR)
09600
09700	(DEFPROP DATUMIZE
09800		 (LAMBDA (THING) (COND ((ATOM THING) THING) ((DATUM THING))))
09900	 	 EXPR)
10000
10100	(DEFPROP ATOMIZE
10200		 (LAMBDA(ELEMENT)
10300		  (COND ((ATOM ELEMENT) ELEMENT)
10400			((ACTOR (CAR ELEMENT)) (QUOTE *VARIABLE))
10500			(T (QUOTE *STRUCTURE))))
10600	 	 EXPR)
10700
10800	(DEFPROP PUSH-CONTEXT
10900		 (LAMBDA N
11000		  (CONS (QUOTE *CONTEXT)
11100			(CONS (CFRAME) (CDR (GETCONTEXT 0 N)))))
11200	 	 EXPR)
11300
11400	(DEFPROP POP-CONTEXT
11500		 (LAMBDA N (CONS (QUOTE *CONTEXT) (CDDR (GETCONTEXT 0 N))))
11600	 	 EXPR)
11700
11800	(DECLARE (UNSPECIAL CFRAMES))
11900	(DEFPROP NEW-CONTEXT
12000		 (LAMBDA(CFRAMES)
12100		  (COND
12200		   ((ORDERED CFRAMES) (CONS (QUOTE *CONTEXT) CFRAMES))
12300		   ((CERR UNORDERED CONTEXT))))
12400	 	 EXPR)
12500
12600	(DECLARE (SPECIAL CFRAMES))
12700
12800	(DEFPROP SPLICE
12900		 (LAMBDA(CONTEXT)
13000		  (PROG NIL
13100			(RPLACD (CDR CONTEXT)
13200				(CONS
13300				 (CFRAME
13400				  (NEWCNUM
13500				   (CADR (CADDR CONTEXT))
13600				   (CADADR CONTEXT)))
13700				 (CDDR CONTEXT)))
13800			(RETURN CONTEXT)))
13900	 	 EXPR)
14000
14100	(DECLARE (SPECIAL EXPR))
14200
14300	(DEFPROP IN-CONTEXT
14400		 (LAMBDA(CONTEXT EXPR)
14500		  (CEVAL
14600		   (QUOTE
14700		    ((CLAMBDA (CONTEXT) (CEVAL (@ . EXPR))) (@ . CONTEXT)))))
14800	 	 EXPR)
14900
15000	(DECLARE (UNSPECIAL EXPR))
15100
15200	(CDEFUN IN-CONTEXT (CONTEXT EXPR) (CEVAL EXPR))
15300
15400	(DEFPROP PATH
15500		 (LAMBDA(C)
15600		  (CONS (QUOTE *CONTEXT) (MAPCAR (QUOTE CADR) (CDR C))))
15700	 	 EXPR)
15800
15900	(DEFPROP CFRAME
16000		 (LAMBDA K
16100		  ((LAMBDA(NFRAME)
16200		    (PROG NIL
16300			  (COND
16400			   ((AND (= NUMACT NUMCON) (= (GCCON) NUMCON))
16500			    (CERR TOO MANY CONTEXT-FRAMES)))
16600			  (PI-OFF)
16700			  (STORE (FRAMES NUMACT) NFRAME)
16800			  (STORE (RFRAMES NUMACT) (CDR NFRAME))
16900			  (SETQ NUMACT (ADD1 NUMACT))
17000			  (PI-ON)
17100			  (RETURN NFRAME)))
17200		   (LIST (QUOTE *CFRAME)
17300			 (COND ((ZEROP K) (SETQ *CNUM (PLUS INCCON *CNUM)))
17400			       (T (ARG 1))))))
17500	 	 EXPR)
17600
17700	(DEFPROP ORDERED
17800		 (LAMBDA(CLIST)
17900		  (OR (NULL CLIST)
18000		      (PROG NIL
18100	 	       LOOP (COND
18200			     ((CDR CLIST)
18300			      (OR (< (CADADR CLIST) (CADAR CLIST))
18400				  (RETURN NIL))
18500			      (SETQ CLIST (CDR CLIST))
18600			      (GO LOOP)))
18700			    (RETURN T))))
18800	 	 EXPR)
18900	(DEFPROP NEWCNUM
19000		 (LAMBDA(LOW HIGH)
19100		  (PROG (N INC INUSE)
19200			(SETQ N (// (PLUS LOW HIGH) 2))
19300			(SETQ INUSE (CNUMSINUSE LOW HIGH))
19400			(SETQ INC 1)
19500	 	   LOOP (COND
19600	((AND(GREATERP HIGH N)(GREATERP N LOW))
19700			  (COND ((MEMBER N INUSE) (SETQ N (PLUS N INC))
19800						  (SETQ INC
19900							(DIFFERENCE
20000							 0
20100							 (ADD1 INC)))
20200						  (GO LOOP))
20300				((RETURN N))))
20400			 ((CERR NO NEW CNUM BETWEEN (* LOW) AND (* HIGH))))))
20500	 	 EXPR)
20600
20700	(DEFPROP CNUMSINUSE
20800		 (LAMBDA(LOW HIGH)
20900		  (PROG (I NUMS J N)
21000			(SETQ I 0)
21100			(SETQ J (SUB1 NUMACT))
21200	 	   LOOP (COND ((> I J) (RETURN NUMS))
21300			      ((OR (> LOW (SETQ N (CAR (RFRAMES I))))
21400				   (> N HIGH)))
21500			      ((SETQ NUMS (CONS N NUMS))))
21600			(SETQ I (ADD1 I))
21700			(GO LOOP)))
21800	 	 EXPR)
21900
22000	(DEFPROP *GCCON
22100		 (LAMBDA NIL
22200		  (PROG (M N)
22300			(SETQ N 0)
22400			(SETQ M NUMACT)
22500	 	   NGCLP
22600			(COND ((= M N) (RETURN N))
22700			      ((EQ (CDR (FRAMES N)) (RFRAMES N))
22800			       (SETQ N (ADD1 N))
22900			       (GO NGCLP)))
23000			(FLUSH (RFRAMES N))
23100			(STORE (RFRAMES N) 0)
23200	 	   MGCLP
23300			(SETQ M (SUB1 M))
23400			(COND ((= M N) (RETURN N))
23500			      ((EQ (CDR (FRAMES M)) (RFRAMES M)) (GO EXCH)))
23600			(FLUSH (RFRAMES M))
23700			(STORE (RFRAMES M) 0)
23800			(GO MGCLP)
23900	 	   EXCH (STORE (FRAMES N) (FRAMES M))
24000			(STORE (RFRAMES N) (RFRAMES M))
24100			(STORE (RFRAMES M) 0)
24200			(GO NGCLP)))
24300	 	 EXPR)
24400
24500	(DEFPROP GCCON
24600		 (LAMBDA(L)
24700		  (PROG NIL
24800			(PI-OFF)
24900			(SETQ L (SETQ NUMACT (*GCCON)))
25000			(PI-ON)
25100			(RETURN L)))
25200	 	 FEXPR)
25300
25400	(DECLARE (SPECIAL PATTERN))
25500
25600	(DEFPROP FLUSH
25700		 (LAMBDA(CFRAME)
25800		  (PROG (THING THINGS N PATTERN TYPE CMARKERS)
25900			(SETQ THINGS (CDR CFRAME))
26000			(SETQ N (CAR CFRAME))
26100	 	   LOOP (COND ((NULL THINGS) (RETURN NIL)))
26200			(COND
26300			 ((AND (REMCFRAME N
26400					  (SETQ CMARKERS
26500						(ANALYZE
26600						 (SETQ THING (CAR THINGS)))))
26700	 		       PATTERN
26800			       (NULL (CDR CMARKERS)))
26900			  (UNINDEX THING
27000	 			   PATTERN
27100				   (GET TYPE (QUOTE *INDEX))
27200				   (EQ TYPE (QUOTE ITEM)))))
27300			(SETQ THINGS (CDR THINGS))
27400			(GO LOOP)))
27500	 	 EXPR)
27600
27700	(DECLARE (UNSPECIAL PATTERN))
27800
27900	(DEFPROP REMCFRAME
28000		 (LAMBDA(N CMARKERS)
28100		  (PROG (M CM)
28200	 	   LOOP1
28300			(COND
28400			 ((NULL (CDR CMARKERS)) (RETURN NIL))
28500			 ((= N (SETQ M (CAADR CMARKERS)))
28600			  (RPLACD CMARKERS (CDDR CMARKERS))
28700			  (RETURN T))
28800			 ((> N M) (SETQ CMARKERS (CDR CMARKERS)) (GO LOOP1)))
28900	 	   LOOP2
29000			(SETQ CMARKERS (CDR CMARKERS))
29100			(COND ((NULL CMARKERS) (RETURN NIL))
29200			      ((ATOM (CADR (SETQ CM (CAR CMARKERS))))
29300			       (AND (MEMBER N (CADR CM))
29400				    (RPLACA (CDR CM)
29500					    (OR (DELETE N (CADR CM) 1)
29600						(QUOTE /+))))))
29700			(GO LOOP2)))
29800	 	 EXPR)
29900
30000	(DEFPROP !" (LAMBDA (L) (!"1 L)) FEXPR)
30100
30200	(DEFPROP !"1
30300		 (LAMBDA(L)
30400		  (COND ((ATOM L) L)
30500			((EQ (CAR L) (QUOTE @)) (EVAL (CDR L)))
30600			((EQ (CAR L) (QUOTE /,))
30700			 (IVAL (CADR L) (QUOTE *TOP)))
30800			((ATOM (CAR L)) (CONS (CAR L) (!"1 (CDR L))))
30900			((EQ (CAAR L) (QUOTE !@))
31000			 (APPEND (EVAL (CDAR L)) (!"1 (CDR L))))
31100			(T (CONS (!"1 (CAR L)) (!"1 (CDR L))))))
31200	 	 EXPR)