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)