(FILECREATED "23-Apr-84 19:49:16" {PHYLUM}<LISPUSERS>OPS5S1.;4 132118
changes to: (VARS OPS5S1COMS)
(MACROS // + - < >)
(FNS ARI RUN CHECK-LIMITS ACCUM-STATS CHECK-TAB-INDEX CHECK-PRINT-CONTROL
CHECK-SUBSTR-INDEX CHECK-RHS-CE-VAR CHECK-BIND BACK RECORD-INDEX-PLUS
PPONLYVAL PPATTVAL IDENT PPWM TABTO RJUST SUBSTR ACCEPTLINE ACCEPT DO-TABTO
DO-RJUST WRITE BIND $PARAMETER $VALUE $TAB GET-NUM-CE ADD-TO-WM CONFLICT-SET
CONFLICT-SET-COMPARE CONFLICT-RESOLUTION DSORT NOT-RIGHT TNEB TEQB TNES TEQS
TNEN TEQN &ANY ENCODE-PAIR MAKE-NUMS NOTE-USER-VECTOR-ASSIGNS I-G-V GELM
NOT-LEFT CMP-CE CHECK-ACCEPT LITVAL CBIND CHECK-SUBSTR CHECK-0-ARGS
CHECK-RJUST CHECK-TABTO CHECK-LITVAL CHECK-CBIND FIELD-NAME CMP-CEVAR
CHECK-TERM CHECK-RHS-VALUE CHECK-BUILD-COLLECT WRITE-ELMS ARI-UNIT $CHANGE
BUILD-COLLECT CMP-P)
previous date: "27-Feb-84 19:25:35" {PHYLUM}<LISPUSERS>OPS5S1.;3)
(* Copyright (c) 1984 by AMOS BARZILAY)
(PRETTYCOMPRINT OPS5S1COMS)
(RPAQQ OPS5S1COMS ((FNS BROKEN MEMQ MYDOLOOP REMATM PBREAK2 SIMPLEOPSTEST SYMBOLP GET GETCHAR PBREAK
EXTERNALP EXTERNAL3 EXTERNAL2 EXTERNAL WATCH CS STRATEGY RUN EXCISE
TOP-LEVEL-REMOVE CHECK-LIMITS PM-SIZE PRINT-TIMES ACCUM-STATS DO-CONTINUE
MAIN PROCESS-CHANGES CE-BOUND? NNREV NOTE-CE-VARIABLE NREVERSE NULLA BOUND?
NOTE-VARIABLE CHECK-TAB-INDEX CHECK-PRINT-CONTROL CHECK-SUBSTR-INDEX
CHECK-LAST-SUBSTR-INDEX CHECK-TERM CHECK-ARITHMETIC CHECK-COMPUTE
CHECK-SUBSTR CHECK-0-ARGS CHECK-RJUST CHECK-TABTO CHECK-GENATOM CHECK-CRLF
CHECK-ACCEPTLINE CHECK-ACCEPT CHECK-LITVAL CHECK-RHS-FUNCTION
CHECK-RHS-ATOMIC CHECK-RHS-VALUE CHECK-RHS-CE-VAR CHECK-CHANGE& CHECK-BIND
CHECK-CBIND CHECK-HALT CHECK-CALL CHECK-WRITE CHECK-MODIFY CHECK-DEFAULT
CHECK-CLOSEFILE CHECK-OPENFILE CHECK-MAKE CHECK-REMOVE CHECK-BUILD-COLLECT
CHECK-BUILD CHECK-ACTION CHECK-RHS FIND-RIGHT-MEM FIND-LEFT-MEM WRITE-ELMS2
WRITE-ELMS MATCHES3 MATCHES2 MATCHES BACK-PRINT STILL-PRESENT UNDO-RECORD
BACK GETVECTOR PUTVECTOR REFRACTED RECORD-REFRACT RECORD-CHANGE END-RECORD
BEGIN-RECORD INITIALIZE-RECORD RECORD-INDEX-PLUS GETUPTO GETVAL PPONLYVAL
PPATTVAL PPLINE2 PPLINE PPRULE PM PPVAL PPELM IDENT FILTER PPWM2 PPWM TABTO
CRLF RJUST LITVAL LOADOPS5 GENATOM ARI-UNIT ARI ARITH COMPUTE SUBSTR
ACCEPTLINE SPAN-CHARS FLAT-VALUE CHECK-FOR-EOF ACCEPT DEFAULT CLOSEFILE2
CLOSEFILE $OFILE $IFILE BUILD HALT DO-TABTO DO-RJUST DEFAULT-WRITE-FILE WRITE
CALL REMOVEWM CBIND BIND MODIFY MAKE $PARAMETER $PARAMETERCOUNT $ASSERT
USE-RESULT-ARRAY $VALUE $TAB RHS-TAB $RESET EVAL-FUNCTION EVAL-ARGS $CHANGE
UNFLAT* UNFLAT BUILD-COLLECT GET-NUM-CE GET-CE-VAR-BIND ASSQ $VARBIND
MAKE-VAR-BIND MAKE-CE-VAR-BIND INIT-CE-VAR-MEM INIT-VAR-MEM TIME-TAG-PRINT
EVAL-RHS TRACE-FILE REFRESH-ADD REFRESH-DEL REFRESH-COLLECT REFRESH
CREATION-TIME WM-HASH GET-WM2 GET-WM WM MAPWM REMOVE-FROM-WM ADD-TO-WM
CONCAT-AMOS CONFLICT-SET CONFLICT-SET-COMPARE INSTANTIATION ORDER-PART
PNAME-INSTANTIATION REMOVE-FROM-CONFLICT-SET BEST-OF* BEST-OF
CONFLICT-RESOLUTION DSORT ORDER-TAGS INSERTCS REMOVECS REMOVE-OLD-NO-NUM
REMOVE-OLD-NUM REMOVE-OLD REAL-ADD-TOKEN ADD-TOKEN NOT-RIGHT NOT-LEFT &NOT
&OLD &P TXXB TLEB TGEB TGTB TLTB TNEB TEQB AND-RIGHT AND-LEFT &AND &MEM &TWO
TLES TGES TGTS TLTS TXXS TNES TEQS TLEN TGEN TGTN TLTN TXXN TNEN TEQN TXXA
TNEA TEQA &ANY &BUS SENDTO EVAL-NODELIST MATCH BETA-EQUIV EQUIV
FIND-EQUIV-BETA-NODE FIND-EQUIV-NODE LEFT-OUTS RIGHT-OUTS ATTACH-LEFT
ATTACH-RIGHT LINK-BOTH LINK-LEFT LINK-NEW-BETA-NODE LINK-TO-BRANCH
LINK-NEW-NODE ENCODE-CE-DOPE ENCODE-DOPE MEMORY-PART PROTOMEM BUILD-BETA
FUDGE* FUDGE PROMOTE-VAR ENCODE-SINGLETON ENCODE-PAIR ADD-TEST CMP-BETA
CMP-AND CMP-NOBETA CMP-NOT CMP-CEVAR CMP-NEW-EQ-VAR CMP-OLD-EQ-VAR
CMP-NEW-VAR CMP-VAR CE-VAR-DOPE VAR-DOPE FIELD-NAME CURRENT-FIELD CMP-NUMBER
CMP-CONSTANT CMP-SYMBOL VARIABLEP CMP-PRODUCT CMP-ATOMIC GET-BIND $LITBIND
CMP-TAB CMP-ANY CMP-ATOMIC-OR-ANY CMP-ELEMENT CMP-CE INCR-SUBNUM NEW-SUBNUM
CMP-CE+CEVAR CMP-POSCE CMP-NEGCE CMP-PRIN KILL-NODE EXCISE-P RHS-PART
CE-VAR-PART VAR-PART RATING-PART CMP-P MAKE-BOTTOM-NODE PREPARE-SUBLEX
REST-OF-CE END-OF-CE SUBLEX PEEK-SUBLEX PREPARE-LEX REST-OF-P END-OF-P LEX
PEEK-LEX COMPILE-PRODUCTION P ERASE-LITERAL-INFO2 ERASE-LITERAL-INFO
MAKE-NUMS BUCKETS ADD-BUCKET STORE-BINDING LITERAL-BINDING-OF
REMOVE-DUPLICATES CONFLICT MARK-CONFLICTS2 MARK-CONFLICTS FIND-COMMON-ATOM
DISJOINT ASSIGN-VECTORS2 ASSIGN-VECTORS ASSIGN-SCALARS2 ASSIGN-SCALARS
NOTE-USER-VECTOR-ASSIGNS NOTE-USER-ASSIGNS2 NOTE-USER-ASSIGNS PUT-PPDAT
HAVE-COMPILED-PRODUCTION FINISH-LITERALIZE TEST-ATTRIBUTE-NAMES2
TEST-ATTRIBUTE-NAMES IS-VECTOR-ATTRIBUTE VECTOR-ATTRIBUTE2 VECTOR-ATTRIBUTE
LITERALIZE LITERAL TOP-LEVELS-EQ ROUND WARN I-G-V INTRQ PRINTLINEC*
PRINTLINEC PRINTLINE* GELM CE-GELM EXIT *MAKHUNK DRAIN NWRITN)
(FNS %%ERROR WARN)
(FNS TYI)
(VARS GG)
(DECLARE: EVAL@COMPILE DONTCOPY (GLOBALVARS * GG)
(MACROS COMMENT + - // 1+ 1- < > == CXR FAST-SYMEVAL FLATC GETVECTOR NCONS
PUTVECTOR)
(P (CLDISABLE (QUOTE MATCH))
(CLDISABLE (QUOTE *))
(CLDISABLE (QUOTE ↑))
(CLDISABLE (QUOTE -))
(CLDISABLE (QUOTE +))
(CLDISABLE (QUOTE <))
(CLDISABLE (QUOTE >))
(CLDISABLE (QUOTE =)))
(VARS (DWIMIFYCOMPFLG)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA EXIT LITERAL LITERALIZE VECTOR-ATTRIBUTE P WM MAKE MODIFY BIND
CBIND REMOVEWM CALL WRITE BUILD CLOSEFILE DEFAULT ACCEPT ACCEPTLINE
SUBSTR COMPUTE ARITH LITVAL RJUST CRLF TABTO PPWM PM MATCHES EXCISE
RUN STRATEGY CS WATCH EXTERNAL PBREAK MYDOLOOP)
(NLAML)
(LAMA)))))
(DEFINEQ
(BROKEN
[LAMBDA (RULE)
(MEMQ RULE *BRKPTS*])
(MEMQ
[LAMBDA (X Y) (* edited: "10-Feb-84 11:28")
(COND
((NULL Y)
NIL)
((EQ X (CAR Y))
Y)
(T (MEMQ X (CDR Y])
(MYDOLOOP
[NLAMBDA N (* edited: "17-Feb-84 11:16")
(PROG (KKK SP REP CONDITION ACTIONS TMP)
(SETQ KKK (CAR N))
(COND
((BOUNDP KKK)
(SETQ TMP (EVAL KKK)))
(T (SETQ TMP NIL)))
(SETQ SP (CADR N))
(SETQ REP (CADDR N))
(SETQ CONDITION (CADDDR N))
(SETQ ACTIONS (CDDDDR N))
(SET KKK (EVAL SP))
(until (EVAL CONDITION)
do (for Y in ACTIONS do (EVAL Y))
(SET KKK (EVAL REP)))
(SET KKK TMP])
(REMATM
[LAMBDA (ATM LIST)
(COND
((ATOM LIST)
LIST)
((EQ ATM (CAR LIST))
(REMATM ATM (CDR LIST)))
(T (CONS (CAR LIST)
(REMATM ATM (CDR LIST])
(PBREAK2
[LAMBDA (RULE)
(COND
((NOT (SYMBOLP RULE))
(WARN "ILLEGAL NAME" RULE))
((NOT (GET RULE (QUOTE TOPNODE)))
(WARN "NOT A PRODUCTION" RULE))
((MEMQ RULE *BRKPTS*)
(SETQ *BRKPTS* (REMATM RULE *BRKPTS*)))
(T (SETQ *BRKPTS* (CONS RULE *BRKPTS*])
(SIMPLEOPSTEST
[LAMBDA NIL (* edited: "20-Feb-84 11:43")
(LITERALIZE GOAL V1 V2 V3 V4)
(P P11 (GOAL)
-->
(WRITE P1 GOAL))
(P P12 (GOAL ↑ V1 { <X1> <> A1 } ↑ V2 { <X2> <> A2 })
-->
(WRITE <X1> <X2>))
(P P13 (GOAL ↑ V1 << A1 B1 >>)
-->
(WRITE A1 B1))
(P P14 (GOAL ↑ V1 { <X> << A1 B1 >> })
-->
(WRITE <X>))
(P P15 (GOAL ↑ V1 { <X> <> 0 })
-->
(WRITE <X>))
(P P16 (GOAL)
-->
(REMOVEWM 1))
(P P17 (GOAL ↑ V1 { <X> << A1 B1 >> })
-->
(MODIFY 1 ↑ V1 MODIFIED))
(MAKE GOAL)
(MAKE GOAL ↑ V1 A1 ↑ V2 A2 ↑ V3 A3)
(MAKE GOAL B1 B2 B3)
(MAKE GOAL ↑ V1 C1 ↑ V2 C2)
(MAKE GOAL ↑ V1 0 ↑ V2 0)
(MAKE GOAL ↑ V1 10 ↑ V2 10])
(SYMBOLP
(LAMBDA (A) (* JonL "15-Feb-84 11:19")
(LITATOM A)))
(GET
[LAMBDA (X Y) (* edited: "10-Feb-84 15:08")
(GETPROP X Y])
(GETCHAR
(LAMBDA (X N) (* JonL "15-Feb-84 12:08")
(NTHCHAR X N)))
(PBREAK
[NLAMBDA Z (* edited: "10-Feb-84 12:41")
(COND
((ATOM Z)
(TERPRI)
*BRKPTS*)
(T (MAPC Z (FUNCTION PBREAK2))
NIL])
(EXTERNALP
[LAMBDA (X) (* edited: "16-Feb-84 13:49")
(COND
((SYMBOLP X)
(GET X (QUOTE EXTERNAL-ROUTINE)))
(T (WARN "NOT A LEGAL FUNCTION NAME" X)
NIL])
(EXTERNAL3
[LAMBDA (X) (* edited: "16-Feb-84 13:49")
(COND
((SYMBOLP X)
(PUTPROP X (QUOTE EXTERNAL-ROUTINE)
T))
(T (%%ERROR "NOT A LEGAL FUNCTION NAME" X])
(EXTERNAL2
[LAMBDA (Z) (* edited: "10-Feb-84 12:48")
(MAPC Z (FUNCTION EXTERNAL3])
(EXTERNAL
(NLAMBDA Z (* JonL "15-Feb-84 11:59")
(*CATCH (QUOTE !ERROR!)
(EXTERNAL2 Z))))
(WATCH
[NLAMBDA Z (* edited: "20-Feb-84 17:46")
(COND
((EQUAL Z (QUOTE (0)))
(SETQ *WTRACE* NIL)
(SETQ *PTRACE* NIL)
0)
((EQUAL Z (QUOTE (1)))
(SETQ *WTRACE* NIL)
(SETQ *PTRACE* T)
1)
((EQUAL Z (QUOTE (2)))
(SETQ *WTRACE* T)
(SETQ *PTRACE* T)
2)
((EQUAL Z (QUOTE (3)))
(SETQ *WTRACE* T)
(SETQ *PTRACE* T)
"2 -- CONFLICT SET TRACE NOT SUPPORTED")
((AND (ATOM Z)
(NULL *PTRACE*))
0)
((AND (ATOM Z)
(NULL *WTRACE*))
1)
((ATOM Z)
2)
(T (QUOTE WHAT?])
(CS
[NLAMBDA Z (* edited: "16-Feb-84 13:48")
(COND
((ATOM Z)
(CONFLICT-SET))
(T (QUOTE WHAT?])
(STRATEGY
[NLAMBDA Z (* edited: "16-Feb-84 13:47")
(COND
((ATOM Z)
*STRATEGY*)
[(EQUAL Z (QUOTE (LEX)))
(SETQ *STRATEGY* (QUOTE (LEX]
[(EQUAL Z (QUOTE (MEA)))
(SETQ *STRATEGY* (QUOTE (MEA]
(T (QUOTE WHAT?)])
(RUN
(NLAMBDA Z (* JonL "23-Apr-84 19:08")
(COND
((ATOM Z)
(SETQ *REMAINING-CYCLES* 1000000)
(DO-CONTINUE NIL))
((AND (ATOM (CDR Z))
(NUMBERP (CAR Z))
(> (CAR Z)
0))
(SETQ *REMAINING-CYCLES* (CAR Z))
(DO-CONTINUE NIL))
(T (QUOTE WHAT?)))))
(EXCISE
[NLAMBDA Z (* edited: "10-Feb-84 12:48")
(MAPC Z (FUNCTION EXCISE-P])
(TOP-LEVEL-REMOVE
[LAMBDA (Z) (* edited: "17-Feb-84 10:26")
(COND
((EQUAL Z (QUOTE (*)))
(PROCESS-CHANGES NIL (GET-WM NIL)))
(T (PROCESS-CHANGES NIL (GET-WM Z])
(CHECK-LIMITS
(LAMBDA NIL (* JonL "23-Apr-84 19:06")
(COND
((> (LENGTH *CONFLICT-SET*)
*LIMIT-CS*)
(TERPRI)
(TERPRI)
(PRINTLINEC (LIST "CONFLICT SET SIZE EXCEEDED THE LIMIT OF" *LIMIT-CS* (QUOTE AFTER)
*P-NAME*))
(SETQ *HALT-FLAG* T)))
(COND
((> *CURRENT-TOKEN* *LIMIT-TOKEN*)
(TERPRI)
(TERPRI)
(PRINTLINEC (LIST "TOKEN MEMORY SIZE EXCEEDED THE LIMIT OF" *LIMIT-TOKEN* (QUOTE AFTER)
*P-NAME*))
(SETQ *HALT-FLAG* T)))))
(PM-SIZE
[LAMBDA NIL
(TERPRI)
[PRINTLINEC (LIST *PCOUNT* (QUOTE PRODUCTIONS)
(LIST *REAL-CNT* (QUOTE //)
*VIRTUAL-CNT*
(QUOTE NODES]
(TERPRI])
(PRINT-TIMES
[LAMBDA (MESS)
(PROG (CC AC)
(COND
(*BREAK-FLAG* (TERPRI)
(RETURN MESS)))
(SETQ CC (PLUS (FLOAT *CYCLE-COUNT*)
1.0E-20))
(SETQ AC (PLUS (FLOAT *ACTION-COUNT*)
1.0E-20))
(TERPRI)
(PRIN1 MESS)
(PM-SIZE)
[PRINTLINEC (LIST *CYCLE-COUNT* (QUOTE FIRINGS)
(LIST *ACTION-COUNT* (QUOTE RHS)
(QUOTE ACTIONS]
(TERPRI)
[PRINTLINEC (LIST (ROUND (QUOTIENT (FLOAT *TOTAL-WM*)
CC))
(QUOTE MEAN)
(QUOTE WORKING)
(QUOTE MEMORY)
(QUOTE SIZE)
(LIST *MAX-WM* (QUOTE MAXIMUM]
(TERPRI)
[PRINTLINEC (LIST (ROUND (QUOTIENT (FLOAT *TOTAL-CS*)
CC))
(QUOTE MEAN)
(QUOTE CONFLICT)
(QUOTE SET)
(QUOTE SIZE)
(LIST *MAX-CS* (QUOTE MAXIMUM]
(TERPRI)
[PRINTLINEC (LIST (ROUND (QUOTIENT (FLOAT *TOTAL-TOKEN*)
CC))
(QUOTE MEAN)
(QUOTE TOKEN)
(QUOTE MEMORY)
(QUOTE SIZE)
(LIST *MAX-TOKEN* (QUOTE MAXIMUM]
(TERPRI])
(ACCUM-STATS
(LAMBDA NIL (* JonL "23-Apr-84 19:06")
(SETQ *CYCLE-COUNT* (IPLUS 1 *CYCLE-COUNT*))
(SETQ *TOTAL-TOKEN* (+ *TOTAL-TOKEN* *CURRENT-TOKEN*))
(COND
((> *CURRENT-TOKEN* *MAX-TOKEN*)
(SETQ *MAX-TOKEN* *CURRENT-TOKEN*)))
(SETQ *TOTAL-WM* (+ *TOTAL-WM* *CURRENT-WM*))
(COND
((> *CURRENT-WM* *MAX-WM*)
(SETQ *MAX-WM* *CURRENT-WM*)))))
(DO-CONTINUE
(LAMBDA (WMI) (* JonL "15-Feb-84 14:48")
(COND
(*CRITICAL* (TERPRI)
(PRIN1 "WARNING: NETWORK MAY BE INCONSISTENT")))
(PROCESS-CHANGES WMI NIL)
(PRINT-TIMES (MAIN))))
(MAIN
[LAMBDA NIL (* edited: "16-Feb-84 10:07")
(PROG (INSTANCE R)
(SETQ *HALT-FLAG* NIL)
(SETQ *BREAK-FLAG* NIL)
(SETQ INSTANCE NIL)
DIL (SETQ *PHASE* (QUOTE CONFLICT-RESOLUTION))
(COND
(*HALT-FLAG* (SETQ R "END -- EXPLICIT HALT")
(GO FINIS))
((ZEROP *REMAINING-CYCLES*)
(SETQ R (QUOTE ***BREAK***))
(SETQ *BREAK-FLAG* T)
(GO FINIS))
(*BREAK-FLAG* (SETQ R (QUOTE ***BREAK***))
(GO FINIS)))
(SETQ *REMAINING-CYCLES* (SUB1 *REMAINING-CYCLES*))
(SETQ INSTANCE (CONFLICT-RESOLUTION))
(COND
((NOT INSTANCE)
(SETQ R (QUOTE (END NO PRODUCTION TRUE)))
(GO FINIS)))
(SETQ *PHASE* (CAR INSTANCE))
(ACCUM-STATS)
(EVAL-RHS (CAR INSTANCE)
(CDR INSTANCE))
(CHECK-LIMITS)
(AND (BROKEN (CAR INSTANCE))
(SETQ *BREAK-FLAG* T))
(GO DIL)
FINIS
(SETQ *P-NAME* NIL)
(RETURN R])
(PROCESS-CHANGES
[LAMBDA (ADDS DELS)
(PROG (X)
PROCESS-DELETES
(AND (ATOM DELS)
(GO PROCESS-ADDS))
(SETQ X (CAR DELS))
(SETQ DELS (CDR DELS))
(REMOVE-FROM-WM X)
(GO PROCESS-DELETES)
PROCESS-ADDS
(AND (ATOM ADDS)
(RETURN NIL))
(SETQ X (CAR ADDS))
(SETQ ADDS (CDR ADDS))
(ADD-TO-WM X NIL)
(GO PROCESS-ADDS])
(CE-BOUND?
[LAMBDA (CE-VAR)
(OR (MEMQ CE-VAR *RHS-BOUND-CE-VARS*)
(CE-VAR-DOPE CE-VAR])
(NNREV
[LAMBDA (X Y) (* pkh: "13-Feb-84 11:52")
(COND
((NULL (CDR X))
(RPLACD X Y))
((NNREV (CDR X)
(RPLACD X Y])
(NOTE-CE-VARIABLE
[LAMBDA (CE-VAR)
(SETQ *RHS-BOUND-CE-VARS*(CONS CE-VAR *RHS-BOUND-CE-VARS*])
(NREVERSE
[LAMBDA (X) (* pkh: "13-Feb-84 11:50")
(COND
((NULL X)
NIL)
((NNREV X NIL])
(NULLA
[LAMBDA (X) (* pkh: "13-Feb-84 14:09")
(COND
((NULL X)
NIL)
((ATOM X)
NIL)
((AND (NULL (CAR X))
(NULLA (CDR X)))
NIL)
(T T])
(BOUND?
[LAMBDA (VAR)
(OR (MEMQ VAR *RHS-BOUND-VARS*)
(VAR-DOPE VAR])
(NOTE-VARIABLE
[LAMBDA (VAR)
(SETQ *RHS-BOUND-VARS*(CONS VAR *RHS-BOUND-VARS*])
(CHECK-TAB-INDEX
(LAMBDA (X) (* JonL "23-Apr-84 19:06")
(PROG (V)
(COND
((BOUND? X)
(RETURN X)))
(SETQ V ($LITBIND X))
(COND
((NOT (NUMBERP V))
(WARN "UNBOUND SYMBOL OCCURS AFTER ↑" X))
((OR (< V 1)
(> V 127))
(WARN "INDEX OUT OF BOUNDS AFTER ↑" X))))))
(CHECK-PRINT-CONTROL
(LAMBDA (X) (* JonL "23-Apr-84 19:06")
(PROG NIL
(COND
((BOUND? X)
(RETURN X)))
(COND
((OR (NOT (NUMBERP X))
(< X 1)
(> X 127))
(WARN "ILLEGAL VALUE FOR PRINTER CONTROL" X))))))
(CHECK-SUBSTR-INDEX
(LAMBDA (X) (* JonL "23-Apr-84 19:06")
(PROG (V)
(COND
((BOUND? X)
(RETURN X)))
(SETQ V ($LITBIND X))
(COND
((NOT (NUMBERP V))
(WARN "UNBOUND SYMBOL USED AS INDEX IN SUBSTR" X))
((OR (< V 1)
(> V 127))
(WARN "INDEX OUT OF BOUNDS IN TAB" X))))))
(CHECK-LAST-SUBSTR-INDEX
[LAMBDA (X) (* edited: "16-Feb-84 13:41")
(OR (EQ X (QUOTE INF))
(CHECK-SUBSTR-INDEX X])
(CHECK-TERM
(LAMBDA (X) (* JonL "23-Apr-84 19:44")
(COND
((DTPR X)
(CHECK-ARITHMETIC X))
(T (CHECK-RHS-ATOMIC X)))))
(CHECK-ARITHMETIC
[LAMBDA (L) (* edited: "16-Feb-84 13:40")
(COND
((ATOM L)
(WARN "SYNTAX ERROR IN ARITHMETIC EXPRESSION" L))
((ATOM (CDR L))
(CHECK-TERM (CAR L)))
([NOT (MEMQ (CADR L)
(QUOTE (+ - * // \\]
(WARN "UNKNOWN OPERATOR" L))
(T (CHECK-TERM (CAR L))
(CHECK-ARITHMETIC (CDDR L])
(CHECK-COMPUTE
[LAMBDA (X)
(CHECK-ARITHMETIC (CDR X])
(CHECK-SUBSTR
(LAMBDA (X) (* JonL "23-Apr-84 19:31")
(OR (==(LENGTH X)
4)
(WARN "WRONG NUMBER OF ARGUMENTS" X))
(CHECK-RHS-CE-VAR (CADR X))
(CHECK-SUBSTR-INDEX (CADDR X))
(CHECK-LAST-SUBSTR-INDEX (CADDDR X))))
(CHECK-0-ARGS
(LAMBDA (X) (* JonL "23-Apr-84 19:31")
(OR (==(LENGTH X)
1)
(WARN "SHOULD NOT HAVE ARGUMENTS" X))))
(CHECK-RJUST
(LAMBDA (X) (* JonL "23-Apr-84 19:31")
(OR (==(LENGTH X)
2)
(WARN "WRONG NUMBER OF ARGUMENTS" X))
(CHECK-PRINT-CONTROL (CADR X))))
(CHECK-TABTO
(LAMBDA (X) (* JonL "23-Apr-84 19:31")
(OR (==(LENGTH X)
2)
(WARN "WRONG NUMBER OF ARGUMENTS" X))
(CHECK-PRINT-CONTROL (CADR X))))
(CHECK-GENATOM
[LAMBDA (X)
(CHECK-0-ARGS X])
(CHECK-CRLF
[LAMBDA (X)
(CHECK-0-ARGS X])
(CHECK-ACCEPTLINE
[LAMBDA (X) (* edited: "10-Feb-84 12:48")
(MAPC (CDR X)
(FUNCTION CHECK-RHS-ATOMIC])
(CHECK-ACCEPT
(LAMBDA (X) (* JonL "23-Apr-84 19:28")
(SELECTQ (LENGTH X)
(1 NIL)
(2 (CHECK-RHS-ATOMIC (CADR X)))
(WARN "TOO MANY ARGUMENTS" X))))
(CHECK-LITVAL
(LAMBDA (X) (* JonL "23-Apr-84 19:32")
(OR (==(LENGTH X)
2)
(WARN "WRONG NUMBER OF ARGUMENTS" X))
(CHECK-RHS-ATOMIC (CADR X))))
(CHECK-RHS-FUNCTION
[LAMBDA (X) (* edited: "16-Feb-84 13:38")
(PROG (A)
(SETQ A (CAR X))
(COND
((EQ A (QUOTE COMPUTE))
(CHECK-COMPUTE X))
((EQ A (QUOTE ARITH))
(CHECK-COMPUTE X))
((EQ A (QUOTE SUBSTR))
(CHECK-SUBSTR X))
((EQ A (QUOTE ACCEPT))
(CHECK-ACCEPT X))
((EQ A (QUOTE ACCEPTLINE))
(CHECK-ACCEPTLINE X))
((EQ A (QUOTE CRLF))
(CHECK-CRLF X))
((EQ A (QUOTE GENATOM))
(CHECK-GENATOM X))
((EQ A (QUOTE LITVAL))
(CHECK-LITVAL X))
((EQ A (QUOTE TABTO))
(CHECK-TABTO X))
((EQ A (QUOTE RJUST))
(CHECK-RJUST X))
((NOT (EXTERNALP A))
(WARN "RHS FUNCTION NOT DECLARED EXTERNAL" A])
(CHECK-RHS-ATOMIC
[LAMBDA (X)
(AND (VARIABLEP X)
(NOT (BOUND? X))
(WARN "UNBOUND VARIABLE" X])
(CHECK-RHS-VALUE
(LAMBDA (X) (* JonL "23-Apr-84 19:44")
(COND
((DTPR X)
(CHECK-RHS-FUNCTION X))
(T (CHECK-RHS-ATOMIC X)))))
(CHECK-RHS-CE-VAR
(LAMBDA (V) (* JonL "23-Apr-84 19:06")
(COND
((AND (NOT (NUMBERP V))
(NOT (CE-BOUND? V)))
(WARN "UNBOUND ELEMENT VARIABLE" V))
((AND (NUMBERP V)
(OR (< V 1)
(> V *CE-COUNT*)))
(WARN "NUMERIC ELEMENT DESIGNATOR OUT OF BOUNDS" V)))))
(CHECK-CHANGE&
[LAMBDA (Z) (* edited: "16-Feb-84 13:36")
(PROG (R TAB-FLAG)
(SETQ TAB-FLAG NIL)
LA (AND (ATOM Z)
(RETURN NIL))
(SETQ R (CAR Z))
(SETQ Z (CDR Z))
(COND
((EQ R (QUOTE ↑))
(AND TAB-FLAG (WARN "NO VALUE BEFORE THIS TAB" (CAR Z)))
(SETQ TAB-FLAG T)
(CHECK-TAB-INDEX (CAR Z))
(SETQ Z (CDR Z)))
((EQ R (QUOTE //))
(SETQ TAB-FLAG NIL)
(SETQ Z (CDR Z)))
(T (SETQ TAB-FLAG NIL)
(CHECK-RHS-VALUE R)))
(GO LA])
(CHECK-BIND
(LAMBDA (Z) (* JonL "23-Apr-84 19:06")
(PROG (V)
(OR (> (LENGTH Z)
1)
(WARN "NEEDS ARGUMENTS" Z))
(SETQ V (CADR Z))
(OR (VARIABLEP V)
(WARN "TAKES VARIABLE AS ARGUMENT" Z))
(NOTE-VARIABLE V)
(CHECK-CHANGE& (CDDR Z)))))
(CHECK-CBIND
(LAMBDA (Z) (* JonL "23-Apr-84 19:32")
(PROG (V)
(OR (==(LENGTH Z)
2)
(WARN "TAKES ONLY ONE ARGUMENT" Z))
(SETQ V (CADR Z))
(OR (VARIABLEP V)
(WARN "TAKES VARIABLE AS ARGUMENT" Z))
(NOTE-CE-VARIABLE V))))
(CHECK-HALT
[LAMBDA (Z)
(OR (NULL (CDR Z))
(WARN "DOES NOT TAKE ARGUMENTS" Z])
(CHECK-CALL
[LAMBDA (Z) (* edited: "17-Feb-84 10:16")
(PROG (F)
(AND (NULL (CDR Z))
(WARN "NEEDS ARGUMENTS" Z))
(SETQ F (CADR Z))
(AND (VARIABLEP F)
(WARN "FUNCTION NAME MUST BE A CONSTANT" Z))
(OR (SYMBOLP F)
(WARN "FUNCTION NAME MUST BE A SYMBOLIC ATOM" F))
(OR (EXTERNALP F)
(WARN "FUNCTION NAMED NOT DECLARED EXTERNAL" F))
(CHECK-CHANGE& (CDDR Z])
(CHECK-WRITE
[LAMBDA (Z)
(AND (NULL (CDR Z))
(WARN "NEEDS ARGUMENTS" Z))
(CHECK-CHANGE& (CDR Z])
(CHECK-MODIFY
[LAMBDA (Z)
(AND (NULL (CDR Z))
(WARN "NEEDS ARGUMENTS" Z))
(CHECK-RHS-CE-VAR (CADR Z))
(AND (NULL (CDDR Z))
(WARN "NO CHANGES TO MAKE" Z))
(CHECK-CHANGE& (CDDR Z])
(CHECK-DEFAULT
[LAMBDA (Z)
(AND (NULL (CDR Z))
(WARN "NEEDS ARGUMENTS" Z))
(CHECK-CHANGE& (CDR Z])
(CHECK-CLOSEFILE
[LAMBDA (Z)
(AND (NULL (CDR Z))
(WARN "NEEDS ARGUMENTS" Z))
(CHECK-CHANGE& (CDR Z])
(CHECK-OPENFILE
[LAMBDA (Z)
(AND (NULL (CDR Z))
(WARN "NEEDS ARGUMENTS" Z))
(CHECK-CHANGE& (CDR Z])
(CHECK-MAKE
[LAMBDA (Z)
(AND (NULL (CDR Z))
(WARN "NEEDS ARGUMENTS" Z))
(CHECK-CHANGE& (CDR Z])
(CHECK-REMOVE
[LAMBDA (Z) (* edited: "10-Feb-84 12:49")
(AND (NULL (CDR Z))
(WARN "NEEDS ARGUMENTS" Z))
(MAPC (CDR Z)
(FUNCTION CHECK-RHS-CE-VAR])
(CHECK-BUILD-COLLECT
(LAMBDA (ARGS) (* JonL "23-Apr-84 19:44")
(PROG (R)
TOP (AND (NULL ARGS)
(RETURN NIL))
(SETQ R (CAR ARGS))
(SETQ ARGS (CDR ARGS))
(COND
((DTPR R)
(CHECK-BUILD-COLLECT R))
((EQ R (QUOTE \\))
(AND (NULL ARGS)
(WARN "NOTHING TO EVALUATE" R))
(CHECK-RHS-VALUE (CAR ARGS))
(SETQ ARGS (CDR ARGS))))
(GO TOP))))
(CHECK-BUILD
[LAMBDA (Z)
(AND (NULL (CDR Z))
(WARN "NEEDS ARGUMENTS" Z))
(CHECK-BUILD-COLLECT (CDR Z])
(CHECK-ACTION
[LAMBDA (X) (* edited: "20-Feb-84 17:47")
(PROG (A)
(COND
((ATOM X)
(WARN "ATOMIC ACTION" X)
(RETURN NIL)))
(SETQ A (SETQ *ACTION-TYPE* (CAR X)))
(COND
((EQ A (QUOTE BIND))
(CHECK-BIND X))
((EQ A (QUOTE CBIND))
(CHECK-CBIND X))
((EQ A (QUOTE MAKE))
(CHECK-MAKE X))
((EQ A (QUOTE MODIFY))
(CHECK-MODIFY X))
((EQ A (QUOTE REMOVEWM))
(CHECK-REMOVE X))
((EQ A (QUOTE WRITE))
(CHECK-WRITE X))
((EQ A (QUOTE CALL))
(CHECK-CALL X))
((EQ A (QUOTE HALT))
(CHECK-HALT X))
((EQ A (QUOTE OPENFILE))
(CHECK-OPENFILE X))
((EQ A (QUOTE CLOSEFILE))
(CHECK-CLOSEFILE X))
((EQ A (QUOTE DEFAULT))
(CHECK-DEFAULT X))
((EQ A (QUOTE BUILD))
(CHECK-BUILD X))
(T (WARN "UNDEFINED RHS ACTION" A])
(CHECK-RHS
[LAMBDA (RHS) (* edited: "10-Feb-84 12:49")
(MAPC RHS (FUNCTION CHECK-ACTION])
(FIND-RIGHT-MEM
[LAMBDA (NODE)
(MEMORY-PART (CADDDR NODE])
(FIND-LEFT-MEM
[LAMBDA (NODE) (* edited: "16-Feb-84 13:29")
(COND
((EQ (CAR NODE)
(QUOTE &AND))
(MEMORY-PART (CADDR NODE)))
(T (CAR (CADDR NODE])
(WRITE-ELMS2
[LAMBDA (X)
(PRIN1 " ")
(PRIN1 (CREATION-TIME X])
(WRITE-ELMS
(LAMBDA (WME-OR-COUNT) (* JonL "23-Apr-84 19:44")
(COND
((DTPR WME-OR-COUNT)
(TERPRI)
(MAPC WME-OR-COUNT (FUNCTION WRITE-ELMS2))))))
(MATCHES3
[LAMBDA (NODES CE PART) (* edited: "16-Feb-84 13:26")
(COND
((NOT (NULL NODES))
(TERPRI)
(PRIN1 "** MATCHES FOR ")
(PRIN1 PART)
(PRIN1 " ** ")
(MAPC (FIND-LEFT-MEM (CAR NODES))
(FUNCTION WRITE-ELMS))
(TERPRI)
(PRIN1 "** MATCHES FOR ")
(PRIN1 (NCONS CE))
(PRIN1 " ** ")
(MAPC (FIND-RIGHT-MEM (CAR NODES))
(FUNCTION WRITE-ELMS))
(MATCHES3 (CDR NODES)
(1+ CE)
(CONS CE PART])
(MATCHES2
[LAMBDA (P) (* edited: "16-Feb-84 13:24")
(COND
((ATOM P)
(TERPRI)
(TERPRI)
(PRIN1 P)
(MATCHES3 (GET P (QUOTE BACKPOINTERS))
2
(NCONS 1])
(MATCHES
[NLAMBDA RULE-LIST (* edited: "10-Feb-84 12:40")
(MAPC RULE-LIST (FUNCTION MATCHES2))
(TERPRI])
(BACK-PRINT
[LAMBDA (X)
(PROG (PORT)
(SETQ PORT (TRACE-FILE))
(TERPRI PORT)
(PRINT X PORT])
(STILL-PRESENT
[LAMBDA (DATA)
(PROG NIL
L: (COND
((ATOM DATA)
(RETURN T))
((CREATION-TIME (CAR DATA))
(SETQ DATA (CDR DATA))
(GO L:))
(T (RETURN NIL])
(UNDO-RECORD
[LAMBDA (R) (* edited: "17-Feb-84 10:33")
(PROG (SAVE ACT A B RATE)
(COMMENT *RECORDING* MUST BE OFF DURING BACK UP)
(SETQ SAVE *RECORDING*)
(SETQ *REFRACTS* NIL)
(SETQ *RECORDING* NIL)
[AND *PTRACE* (BACK-PRINT (LIST (QUOTE UNDO:)
(CAR R)
(CADR R]
(SETQ R (CDDR R))
TOP (AND (ATOM R)
(GO FIN))
(SETQ ACT (CAR R))
(SETQ A (CADR R))
(SETQ B (CADDR R))
(SETQ R (CDDDR R))
(AND *WTRACE* (BACK-PRINT (LIST (QUOTE UNDO:)
ACT A)))
[COND
((EQ ACT (QUOTE <=WM))
(ADD-TO-WM B A))
((EQ ACT (QUOTE =>WM))
(REMOVE-FROM-WM B))
((EQ ACT (QUOTE <=REFRACT))
(SETQ *REFRACTS* (CONS (CONS A B)
*REFRACTS*)))
((AND (EQ ACT (QUOTE =>REFRACT))
(STILL-PRESENT B))
(SETQ *REFRACTS* (DREMOVE (CONS A B)
*REFRACTS*))
[SETQ RATE (RATING-PART (GET A (QUOTE TOPNODE]
(REMOVECS A B)
(INSERTCS A B RATE))
(T (WARN "BACK: CANNOT UNDO ACTION" (LIST ACT A]
(GO TOP)
FIN (SETQ *RECORDING* SAVE)
(SETQ *REFRACTS* NIL)
(RETURN NIL])
(BACK
(LAMBDA (K) (* JonL "23-Apr-84 19:06")
(PROG (R)
L: (AND (< K 1)
(RETURN NIL))
(SETQ R (GETVECTOR *RECORD-ARRAY* *RECORD-INDEX*))
(AND (NULL R)
(RETURN "NOTHING MORE STORED"))
(PUTVECTOR *RECORD-ARRAY* *RECORD-INDEX* NIL)
(RECORD-INDEX-PLUS -1)
(UNDO-RECORD R)
(SETQ K (1- K))
(GO L:))))
(GETVECTOR
[LAMBDA (H N) (* edited: "10-Feb-84 15:01")
(ELT H (ADD1 N])
(PUTVECTOR
[LAMBDA (H N V) (* edited: "10-Feb-84 15:01")
(SETA H (ADD1 N)
V])
(REFRACTED
[LAMBDA (RULE DATA)
(PROG (Z)
(AND (NULL *REFRACTS*)
(RETURN NIL))
(SETQ Z (CONS RULE DATA))
(RETURN (MEMBER Z *REFRACTS*])
(RECORD-REFRACT
[LAMBDA (RULE DATA) (* edited: "16-Feb-84 13:20")
(AND *RECORDING* (SETQ *RECORD* (CONS (QUOTE <=REFRACT)
(CONS RULE (CONS DATA *RECORD*])
(RECORD-CHANGE
[LAMBDA (DIRECT TIME ELM)
(COND
(*RECORDING* (SETQ *RECORD*(CONS DIRECT (CONS TIME (CONS ELM *RECORD*])
(END-RECORD
(LAMBDA NIL (* JonL "15-Feb-84 12:54")
(COND
(*RECORDING* (SETQ *RECORD* (CONS *CYCLE-COUNT* (CONS *P-NAME* *RECORD*)))
(RECORD-INDEX-PLUS 1)
(PUTVECTOR *RECORD-ARRAY* *RECORD-INDEX* *RECORD*)
(SETQ *RECORD* NIL)
(SETQ *RECORDING* NIL)))))
(BEGIN-RECORD
[LAMBDA (P DATA)
(SETQ *RECORDING* T)
(SETQ *RECORD* (LIST (QUOTE =>REFRACT)
P DATA])
(INITIALIZE-RECORD
(LAMBDA NIL (* JonL "15-Feb-84 12:54")
(SETQ *RECORD-INDEX* 0)
(SETQ *RECORDING* NIL)
(SETQ *MAX-RECORD-INDEX* 31)
(PUTVECTOR *RECORD-ARRAY* 0 NIL)))
(RECORD-INDEX-PLUS
(LAMBDA (K) (* JonL "23-Apr-84 19:06")
(SETQ *RECORD-INDEX* (+ K *RECORD-INDEX*))
(COND
((< *RECORD-INDEX* 0)
(SETQ *RECORD-INDEX* *MAX-RECORD-INDEX*))
((> *RECORD-INDEX* *MAX-RECORD-INDEX*)
(SETQ *RECORD-INDEX* 0)))))
(GETUPTO
[LAMBDA (END)
(PROG (V)
(AND (ATOM *PPLINE*)
(RETURN NIL))
(SETQ V (CAR *PPLINE*))
(SETQ *PPLINE*(CDR *PPLINE*))
(COND
((EQ V END)
(RETURN (LIST V)))
(T (RETURN (CONS V (GETUPTO END])
(GETVAL
[LAMBDA NIL (* edited: "16-Feb-84 11:11")
(PROG (RES V1)
(SETQ V1 (CAR *PPLINE*))
(SETQ *PPLINE* (CDR *PPLINE*))
[COND
[(MEMQ V1 (QUOTE (<> = < <+ => > <=>)))
(SETQ RES (CONS V1 (GETVAL]
[(EQ V1 (QUOTE {))
(SETQ RES (CONS V1 (GETUPTO (QUOTE }]
[(EQ V1 (QUOTE <<))
(SETQ RES (CONS V1 (GETUPTO (QUOTE >>]
((EQ V1 (QUOTE //))
(SETQ RES (LIST V1 (CAR *PPLINE*)))
(SETQ *PPLINE* (CDR *PPLINE*)))
(T (SETQ RES (LIST V1]
(RETURN RES])
(PPONLYVAL
(LAMBDA NIL (* JonL "23-Apr-84 19:06")
(PROG (VAL NEEDSPACE)
(SETQ VAL (GETVAL))
(SETQ NEEDSPACE NIL)
(COND
((> (+ (NWRITN T)
(FLATC VAL))
76)
(SETQ NEEDSPACE NIL)
(TERPRI)
(PRIN1 " ")))
TOP (AND (ATOM VAL)
(RETURN NIL))
(AND NEEDSPACE (PRIN1 " "))
(SETQ NEEDSPACE T)
(PRIN1 (CAR VAL))
(SETQ VAL (CDR VAL))
(GO TOP))))
(PPATTVAL
(LAMBDA NIL (* JonL "23-Apr-84 19:06")
(PROG (ATT VAL)
(SETQ ATT (CADR *PPLINE*))
(SETQ *PPLINE* (CDDR *PPLINE*))
(SETQ VAL (GETVAL))
(COND
((> (+ (NWRITN T)
(FLATC ATT)
(FLATC VAL))
76)
(TERPRI)
(PRIN1 " " T)))
(PRIN1 (QUOTE ↑))
(PRIN1 ATT)
(MAPC VAL (FUNCTION (LAMBDA (Z)
(PRIN1 " " T)
(PRIN1 Z)))))))
(PPLINE2
[LAMBDA NIL (* edited: "16-Feb-84 11:16")
(PROG (NEEDSPACE)
(SETQ NEEDSPACE NIL)
TOP (AND (ATOM *PPLINE*)
(RETURN NIL))
(AND NEEDSPACE (PRIN1 " " T))
(COND
((EQ (CAR *PPLINE*)
(QUOTE ↑))
(PPATTVAL))
(T (PPONLYVAL)))
(SETQ NEEDSPACE T)
(GO TOP])
(PPLINE
[LAMBDA (LINE) (* edited: "16-Feb-84 10:53")
(PROG NIL
(COND
((ATOM LINE)
(PRIN1 LINE))
(T (PRIN1 "(")
(SETQ *PPLINE* LINE)
(PPLINE2)
(PRIN1 " )")))
(RETURN NIL])
(PPRULE
[LAMBDA (NAME) (* edited: "16-Feb-84 11:06")
(PROG (MATRIX NEXT LAB)
(AND (NOT (SYMBOLP NAME))
(RETURN NIL))
(SETQ MATRIX (GET NAME (QUOTE PRODUCTION)))
(AND (NULL MATRIX)
(RETURN NIL))
(TERPRI)
(PRIN1 "(P " T)
(PRIN1 NAME T)
TOP (AND (ATOM MATRIX)
(GO FIN))
(SETQ NEXT (CAR MATRIX))
(SETQ MATRIX (CDR MATRIX))
(SETQ LAB NIL)
(TERPRI)
(COND
((EQ NEXT (QUOTE -))
(PRIN1 " - ")
(SETQ NEXT (CAR MATRIX))
(SETQ MATRIX (CDR MATRIX)))
((EQ NEXT (QUOTE -->))
(PRIN1 " "))
((AND (EQ NEXT (QUOTE {))
(ATOM (CAR MATRIX)))
(PRIN1 " {")
(SETQ LAB (CAR MATRIX))
(SETQ NEXT (CADR MATRIX))
(SETQ MATRIX (CDDDR MATRIX)))
((EQ NEXT (QUOTE {))
(PRIN1 " {" T)
(SETQ LAB (CADR MATRIX))
(SETQ NEXT (CAR MATRIX))
(SETQ MATRIX (CDDDR MATRIX)))
(T (PRIN1 " " T)))
(PPLINE NEXT)
(COND
(LAB (PRIN1 " " T)
(PRIN1 LAB)
(PRIN1 (QUOTE })
T)))
(GO TOP)
FIN (PRIN1 ")"])
(PM
[NLAMBDA Z (* edited: "10-Feb-84 12:42")
(MAPC Z (FUNCTION PPRULE))
(TERPRI)
NIL])
(PPVAL
[LAMBDA (VAL ATT LPOS PORT) (* edited: "16-Feb-84 18:15")
(COND
((NOT (EQUAL ATT (IPLUS 1 LPOS)))
(PRIN1 (QUOTE ↑)
PORT)
(PRIN1 ATT PORT)
(PRIN1 " " PORT)))
(PRIN1 VAL PORT])
(PPELM
[LAMBDA (ELM PORT) (* edited: "16-Feb-84 10:42")
(PROG (PPDAT SEP VAL ATT MODE LASTPOS VLIST)
(PRIN1 (CREATION-TIME ELM)
PORT)
(PRIN1 (QUOTE %|:)
PORT)
(SETQ MODE (QUOTE VECTOR))
(SETQ PPDAT (GET (CAR ELM)
(QUOTE PPDAT)))
(AND PPDAT (SETQ MODE (QUOTE A-V)))
(SETQ SEP "(")
(SETQ LASTPOS 0)
(SETQ VLIST ELM)
[MYDOLOOP CURPOS 1 (IPLUS 1 CURPOS)
(ATOM VLIST)
(SETQ VAL (CAR VLIST))
(SETQ VLIST (CDR VLIST))
(SETQ ATT (ASSOC CURPOS PPDAT))
(COND
(ATT (SETQ ATT (CDR ATT)))
(T (SETQ ATT CURPOS)))
(AND (SYMBOLP ATT)
(IS-VECTOR-ATTRIBUTE ATT)
(SETQ MODE (QUOTE VECTOR)))
(COND
((OR (NOT (NULL VAL))
(EQ MODE (QUOTE VECTOR)))
(PRIN1 SEP PORT)
(PPVAL VAL ATT LASTPOS PORT)
(SETQ SEP " ")
(SETQ LASTPOS CURPOS]
(PRIN1 ")" PORT])
(IDENT
(LAMBDA (X Y) (* JonL "23-Apr-84 19:06")
(COND
((EQ X Y)
T)
((NOT (NUMBERP X))
NIL)
((NOT (NUMBERP Y))
NIL)
((=ALG X Y)
T)
(T NIL))))
(FILTER
[LAMBDA (ELM)
(PROG (FL INDX VAL)
(SETQ FL *FILTERS*)
TOP (AND (ATOM FL)
(RETURN T))
(SETQ INDX (CAR FL))
(SETQ VAL (CADR FL))
(SETQ FL (CDDR FL))
(AND (IDENT (NTH (1- INDX)
ELM)
VAL)
(GO TOP))
(RETURN NIL])
(PPWM2
[LAMBDA (ELM-TAG)
(COND
((FILTER (CAR ELM-TAG))
(TERPRI)
(PPELM (CAR ELM-TAG)
T])
(PPWM
(NLAMBDA AVLIST (* JonL "23-Apr-84 19:06")
(PROG (NEXT A)
(SETQ *FILTERS* NIL)
(SETQ NEXT 1)
L: (AND (ATOM AVLIST)
(GO PRINT))
(SETQ A (CAR AVLIST))
(SETQ AVLIST (CDR AVLIST))
(COND
((EQ A (QUOTE ↑))
(SETQ NEXT (CAR AVLIST))
(SETQ AVLIST (CDR AVLIST))
(SETQ NEXT ($LITBIND NEXT))
(AND (FLOATP NEXT)
(SETQ NEXT (FIX NEXT)))
(COND
((OR (NOT (NUMBERP NEXT))
(> NEXT *SIZE-RESULT-ARRAY*)
(> 1 NEXT))
(WARN "ILLEGAL INDEX AFTER ↑" NEXT)
(RETURN NIL))))
((VARIABLEP A)
(WARN "PPWM DOES NOT TAKE VARIABLES" A)
(RETURN NIL))
(T (SETQ *FILTERS* (CONS NEXT (CONS A *FILTERS*)))
(SETQ NEXT (1+ NEXT))))
(GO L:)
PRINT
(MAPWM (FUNCTION PPWM2))
(TERPRI)
(RETURN NIL))))
(TABTO
(NLAMBDA Z (* JonL "23-Apr-84 19:27")
(PROG (VAL)
(COND
((NOT (==(LENGTH Z)
1))
(WARN "TABTO: WRONG NUMBER OF ARGUMENTS" Z)
(RETURN NIL)))
(SETQ VAL ($VARBIND (CAR Z)))
(COND
((OR (NOT (NUMBERP VAL))
(< VAL 1)
(> VAL 127))
(WARN "TABTO: ILLEGAL COLUMN NUMBER" Z)
(RETURN NIL)))
($VALUE "=== T A B T O ===")
($VALUE VAL))))
(CRLF
[NLAMBDA Z (* edited: "17-Feb-84 10:53")
(COND
(Z (WARN "CRLF: DOES NOT TAKE ARGUMENTS" Z))
(T ($VALUE "=== C R L F ==="])
(RJUST
(NLAMBDA Z (* JonL "23-Apr-84 19:28")
(PROG (VAL)
(COND
((NOT (==(LENGTH Z)
1))
(WARN "RJUST: WRONG NUMBER OF ARGUMENTS" Z)
(RETURN NIL)))
(SETQ VAL ($VARBIND (CAR Z)))
(COND
((OR (NOT (NUMBERP VAL))
(< VAL 1)
(> VAL 127))
(WARN "RJUST: ILLEGAL VALUE FOR FIELD WIDTH" VAL)
(RETURN NIL)))
($VALUE "=== R J U S T ===")
($VALUE VAL))))
(LITVAL
(NLAMBDA Z (* JonL "23-Apr-84 19:28")
(PROG (R)
(COND
((NOT (==(LENGTH Z)
1))
(WARN "LITVAL: WRONG NUMBER OF ARGUMENTS" Z)
($VALUE 0)
(RETURN NIL))
((NUMBERP (CAR Z))
($VALUE (CAR Z))
(RETURN NIL)))
(SETQ R ($LITBIND ($VARBIND (CAR Z))))
(COND
((NUMBERP R)
($VALUE R)
(RETURN NIL)))
(WARN "LITVAL: ARGUMENT HAS NO LITERAL BINDING" (CAR Z))
($VALUE 0))))
(LOADOPS5
[LAMBDA (NAME) (* dsj "24-Feb-84 19:32")
(PROG (X)
(OPENFILE NAME (QUOTE INPUT))
(SETQ ERRORTYPELST (CONS (QUOTE (16 NIL))
ERRORTYPELST))
(while (SETQ X (READ NAME)) DO (EVAL X))
(SETQ ERRORTYPELST (CDR ERRORTYPELST))
(RETURN NIL])
(GENATOM
[LAMBDA NIL
($VALUE (GENSYM])
(ARI-UNIT
(LAMBDA (A) (* JonL "23-Apr-84 19:44")
(PROG (R)
(COND
((DTPR A)
(SETQ R (ARI A)))
(T (SETQ R ($VARBIND A))))
(COND
((NOT (NUMBERP R))
(WARN "BAD VALUE IN ARITHMETIC EXPRESSION" A)
(RETURN 0))
(T (RETURN R))))))
(ARI
(LAMBDA (X) (* JonL "23-Apr-84 19:00")
(COND
((ATOM X)
(WARN "BAD SYNTAX IN ARITHMETIC EXPRESSION" X)
0)
((ATOM (CDR X))
(ARI-UNIT (CAR X)))
((EQ (CADR X)
(QUOTE +))
(PLUS (ARI-UNIT (CAR X))
(ARI (CDDR X))))
((EQ (CADR X)
(QUOTE -))
(DIFFERENCE (ARI-UNIT (CAR X))
(ARI (CDDR X))))
((EQ (CADR X)
(QUOTE *))
(TIMES (ARI-UNIT (CAR X))
(ARI (CDDR X))))
((EQ (CADR X)
(QUOTE /))
(QUOTIENT (ARI-UNIT (CAR X))
(ARI (CDDR X))))
((EQ (CADR X)
(QUOTE \\))
(IMOD (ARI-UNIT (CAR X))
(ARI (CDDR X))))
(T (WARN "BAD SYNTAX IN ARITHMETIC EXPRESSION" X)
0))))
(ARITH
[NLAMBDA Z
($VALUE (ARI Z])
(COMPUTE
[NLAMBDA Z
($VALUE (ARI Z])
(SUBSTR
(NLAMBDA L (* JonL "23-Apr-84 19:11")
(PROG (K ELM START END)
(COND
((NOT (==(LENGTH L)
3))
(WARN "SUBSTR: WRONG NUMBER OF ARGUMENTS" L)
(RETURN NIL)))
(SETQ ELM (GET-CE-VAR-BIND (CAR L)))
(COND
((NULL ELM)
(WARN "FIRST ARGUMENT TO SUBSTR MUST BE A CE VAR" L)
(RETURN NIL)))
(SETQ START ($VARBIND (CADR L)))
(SETQ START ($LITBIND START))
(COND
((NOT (NUMBERP START))
(WARN "SECOND ARGUMENT TO SUBSTR MUST BE A NUMBER" L)
(RETURN NIL)))
(COMMENT %|IF A VARIABLE IS BOUND TO INF, THE FOLLOWING%| %|WILL GET THE BINDING
AND TREAT IT AS INF IS%| %|ALWAYS TREATED. THAT MAY NOT BE GOOD%|)
(SETQ END ($VARBIND (CADDR L)))
(COND
((EQ END (QUOTE INF))
(SETQ END (LENGTH ELM))))
(SETQ END ($LITBIND END))
(COND
((NOT (NUMBERP END))
(WARN "THIRD ARGUMENT TO SUBSTR MUST BE A NUMBER" L)
(RETURN NIL)))
(COMMENT %|THIS LOOP DOES NOT CHECK FOR THE END OF ELM%| %|INSTEAD IT RELIES ON CDR OF NIL
BEING NIL%| %|THIS MAY NOT WORK IN ALL VERSIONS OF LISP%|)
(SETQ K 1)
LA (COND
((> K END)
(RETURN NIL))
((NOT (< K START))
($VALUE (CAR ELM))))
(SETQ ELM (CDR ELM))
(SETQ K (1+ K))
(GO LA))))
(ACCEPTLINE
(NLAMBDA Z (* JonL "23-Apr-84 19:06")
(PROG (C DEF ARG PORT TEM)
(SETQ PORT T)
(SETQ DEF Z)
(COND
(*ACCEPT-FILE* (SETQ PORT ($IFILE *ACCEPT-FILE*))
(COND
((NULL PORT)
(WARN "ACCEPTLINE: FILE HAS BEEN CLOSED" *ACCEPT-FILE*)
(RETURN NIL)))))
(COND
((> (LENGTH DEF)
0)
(SETQ ARG ($VARBIND (CAR DEF)))
(COND
((AND (SYMBOLP ARG)
($IFILE ARG))
(SETQ PORT ($IFILE ARG))
(SETQ DEF (CDR DEF))))))
(COMMENT DELETE END OF LINE IF THERE FROM LAST TIME)
(SETQ PORT (GETSTREAM PORT (QUOTE INPUT)))
(AND (EQ (\PEEKBIN PORT)
(CHARCODE CR))
(SETQ C (BIN PORT)))
(AND (EQ (\PEEKBIN PORT)
(CHARCODE LF))
(SETQ C (BIN PORT)))
(COMMENT CHOP LEADING BLANKS ETC AND THEN LOOK FOR END OF LINE)
(SPAN-CHARS (QUOTE (9 32 131))
PORT)
(COND
((OR (NULL (SETQ TEM (\PEEKBIN PORT T)))
(FMEMB TEM (CHARCODE (CR LF))))
(MAPC DEF (FUNCTION $CHANGE))
(RETURN NIL)))
(COMMENT READ A VALUE FROM INPUT LINE)
L: (FLAT-VALUE (READ PORT NIL))
(COMMENT CHOP OFF IGNORE CHARS AND LOOK FOR END OF LINE)
(SPAN-CHARS (QUOTE (9 32 131))
PORT)
(COND
((OR (NULL (SETQ TEM (\PEEKBIN PORT T)))
(FMEMB TEM (CHARCODE (CR LF))))
(GO L:))))))
(SPAN-CHARS
(LAMBDA (X PRT) (* JonL "15-Feb-84 12:43")
(PROG ((STRM (GETSTREAM PRT (QUOTE INPUT)))
TEM)
(until (OR (NULL (SETQ TEM (\PEEKBIN STRM T)))
(FMEMB TEM X))
do (BIN STRM)))))
(FLAT-VALUE
[LAMBDA (X) (* edited: "10-Feb-84 12:50")
(COND
((ATOM X)
($VALUE X))
(T (MAPC X (FUNCTION FLAT-VALUE])
(CHECK-FOR-EOF
(LAMBDA (FILE) (* JonL "15-Feb-84 12:25")
(COND
((EQ FILE T)
0)
((SKIPSEPRS FILE))
(T -1))))
(ACCEPT
(NLAMBDA Z (* JonL "23-Apr-84 19:29")
(PROG (PORT ARG PEEK)
(COND
((> (LENGTH Z)
1)
(WARN "ACCEPT: WRONG NUMBER OF ARGUMENTS" Z)
(RETURN NIL)))
(SETQ PORT T)
(COND
(*ACCEPT-FILE* (SETQ PORT ($IFILE *ACCEPT-FILE*))
(COND
((NULL PORT)
(WARN "ACCEPT: FILE HAS BEEN CLOSED" *ACCEPT-FILE*)
(RETURN NIL)))))
(COND
((==(LENGTH Z)
1)
(SETQ ARG ($VARBIND (CAR Z)))
(COND
((NOT (SYMBOLP ARG))
(WARN "ACCEPT: ILLEGAL FILE NAME" ARG)
(RETURN NIL)))
(SETQ PORT ($IFILE ARG))
(COND
((NULL PORT)
(WARN "ACCEPT: FILE NOT OPEN FOR INPUT" ARG)
(RETURN NIL)))))
(SETQ PEEK (CHECK-FOR-EOF PORT))
(COND
((== PEEK -1)
($VALUE (QUOTE END-OF-FILE))
(RETURN NIL)))
(FLAT-VALUE (READ PORT (QUOTE END-OF-FILE))))))
(DEFAULT
[NLAMBDA Z (* edited: "16-Feb-84 12:21")
(PROG (FILE USE)
($RESET)
(EVAL-ARGS Z)
(COND
((NOT (EQUAL ($PARAMETERCOUNT)
2))
(WARN "DEFAULT: WRONG NUMBER OF ARGUMENTS" Z)
(RETURN NIL)))
(SETQ FILE ($PARAMETER 1))
(SETQ USE ($PARAMETER 2))
(COND
((NOT (SYMBOLP FILE))
(WARN "DEFAULT: ILLEGAL FILE IDENTIFIER" FILE)
(RETURN NIL))
((NOT (MEMQ USE (QUOTE (WRITE ACCEPT TRACE))))
(WARN "(DEFAULT: ILLEGAL USE FOR A FILE" USE)
(RETURN NIL))
((AND (MEMQ USE ( QUOTE (WRITE TRACE)))
(NOT (NULL FILE))
(NOT ($OFILE FILE)))
(WARN "DEFAULT: FILE HAS NOT BEEN OPENED FOR OUTPUT" FILE)
(RETURN NIL))
((AND (EQ USE (QUOTE ACCEPT))
(NOT (NULL FILE))
(NOT ($IFILE FILE)))
(WARN "DEFAULT: FILE HAS NOT BEEN OPENED FOR INPUT" FILE)
(RETURN NIL))
((EQ USE (QUOTE WRITE))
(SETQ *WRITE-FILE* FILE))
((EQ USE (QUOTE ACCEPT))
(SETQ *ACCEPT-FILE* FILE))
((EQ USE (QUOTE TRACE))
(SETQ *TRACE-FILE* FILE)))
(RETURN NIL])
(CLOSEFILE2
[LAMBDA (FILE)
(PROG (PORT)
(COND
((NOT (SYMBOLP FILE))
(WARN "CLOSEFILE: ILLEGAL FILE IDENTIFIER" FILE))
((SETQ PORT ($IFILE FILE))
(CLOSE PORT)
(REMPROP FILE (QUOTE INPUTFILE)))
((SETQ PORT ($OFILE FILE))
(CLOSE PORT)
(REMPROP FILE (QUOTE OUTPUTFILE))))
(RETURN NIL])
(CLOSEFILE
[NLAMBDA Z (* edited: "10-Feb-84 12:50")
($RESET)
(EVAL-ARGS Z)
(MAPC (USE-RESULT-ARRAY)
(FUNCTION CLOSEFILE2])
($OFILE
[LAMBDA (X)
(COND
((SYMBOLP X)
(GET X (QUOTE OUTPUTFILE)))
(T NIL])
($IFILE
[LAMBDA (X)
(COND
((SYMBOLP X)
(GET X (QUOTE INPUTFILE)))
(T NIL])
(BUILD
[NLAMBDA Z (* edited: " 9-Feb-84 19:29")
(PROG (R)
(COND
((NOT *IN-RHS*)
(WARN "CANNOT BE CALLED AT TOP LEVEL" (QUOTE BUILD))
(RETURN NIL)))
($RESET)
(BUILD-COLLECT Z)
(SETQ R (UNFLAT (USE-RESULT-ARRAY)))
(AND *BUILD-TRACE* (APPLY* *BUILD-TRACE* R))
(COMPILE-PRODUCTION (CAR R)
(CDR R])
(HALT
[LAMBDA NIL (* edited: "17-Feb-84 11:23")
(COND
((NOT *IN-RHS*)
(WARN "CANNOT BE CALLED AT TOP LEVEL" (QUOTE HALT)))
(T (SETQ *HALT-FLAG* T])
(DO-TABTO
(LAMBDA (COL PORT) (* JonL "23-Apr-84 19:06")
(PROG (POS)
(SETQ POS (IPLUS 1 (NWRITN PORT)))
(COND
((> POS COL)
(TERPRI PORT)
(SETQ POS 1)))
(MYDOLOOP K (- COL POS)
(1- K)
(NOT (> K 0))
(PRIN1 " " PORT))
(RETURN NIL))))
(DO-RJUST
(LAMBDA (WIDTH VALUE PORT K) (* JonL "23-Apr-84 19:06")
(PROG (SIZE)
(COND
((EQ VALUE "=== T A B T O ===")
(WARN "RJUST CANNOT PRECEDE THIS FUNCTION" (QUOTE TABTO))
(RETURN NIL))
((EQ VALUE "=== C R L F ===")
(WARN "RJUST CANNOT PRECEDE THIS FUNCTION" (QUOTE CRLF))
(RETURN NIL))
((EQ VALUE "=== R J U S T ===")
(WARN "RJUST CANNOT PRECEDE THIS FUNCTION" (QUOTE RJUST))
(RETURN NIL)))
(SETQ SIZE (FLATC VALUE))
(COND
((> SIZE WIDTH)
(PRIN1 " " PORT)
(PRIN1 VALUE PORT)
(RETURN NIL)))
(DOMYLOOP K (- WIDTH SIZE)
(1- K)
(NOT (> K 0))
(PRIN1 ")" PORT))
(PRIN1 VALUE PORT))))
(DEFAULT-WRITE-FILE
[LAMBDA NIL
(PROG (PORT)
(SETQ PORT T)
[COND
(*WRITE-FILE* (SETQ PORT ($OFILE *WRITE-FILE*))
(COND
((NULL PORT)
(WARN "WRITE: FILE HAS BEEN CLOSED" *WRITE-FILE*)
(SETQ PORT T]
(RETURN PORT])
(WRITE
(NLAMBDA Z (* JonL "23-Apr-84 19:06")
(PROG (PORT MAX K X NEEDSPACE)
(COND
((NOT *IN-RHS*)
(WARN (QUOTE (CANNOT BE CALLED AT TOP LEVEL)))
(RETURN NIL)))
($RESET)
(EVAL-ARGS Z)
(SETQ K 1)
(SETQ MAX ($PARAMETERCOUNT))
(COND
((< MAX 1)
(WARN "WRITE: NOTHING TO PRINT" Z)
(RETURN NIL)))
(SETQ PORT (DEFAULT-WRITE-FILE))
(SETQ X ($PARAMETER 1))
(COND
((AND (SYMBOLP X)
($OFILE X))
(SETQ PORT ($OFILE X))
(SETQ K 2)))
(SETQ NEEDSPACE T)
LA (AND (> K MAX)
(RETURN NIL))
(SETQ X ($PARAMETER K))
(COND
((EQUAL X "=== C R L F ===")
(SETQ NEEDSPACE NIL)
(TERPRI PORT))
((EQUAL X "=== R J U S T ===")
(SETQ K (+ 2 K))
(DO-RJUST ($PARAMETER (1- K))
($PARAMETER K)
PORT))
((EQUAL X "=== T A B T O ===")
(SETQ NEEDSPACE NIL)
(SETQ K (IPLUS 1 K))
(DO-TABTO ($PARAMETER K)
PORT))
(T (AND NEEDSPACE (PRIN1 " " PORT))
(SETQ NEEDSPACE T)
(PRIN1 X PORT)))
(SETQ K (IPLUS 1 K))
(GO LA))))
(CALL
[NLAMBDA Z (* edited: " 9-Feb-84 19:30")
(PROG (F)
(SETQ F (CAR Z))
($RESET)
(EVAL-ARGS (CDR Z))
(APPLY* F])
(REMOVEWM
[NLAMBDA Z
(PROG (OLD)
(AND (NOT *IN-RHS*)
(RETURN (TOP-LEVEL-REMOVE Z)))
TOP (AND (ATOM Z)
(RETURN NIL))
(SETQ OLD (GET-CE-VAR-BIND (CAR Z)))
(COND
((NULL OLD)
(WARN "REMOVE: ARGUMENT NOT AN ELEMENT VARIABLE" (CAR Z))
(RETURN NIL)))
(REMOVE-FROM-WM OLD)
(SETQ Z (CDR Z))
(GO TOP])
(CBIND
(NLAMBDA Z (* JonL "23-Apr-84 19:29")
(COND
((NOT *IN-RHS*)
(WARN "CANNOT BE CALLED AT TOP LEVEL" (QUOTE CBIND)))
((NOT (==(LENGTH Z)
1))
(WARN "CBIND: WRONG NUMBER OF ARGUMENTS" Z))
((NOT (SYMBOLP (CAR Z)))
(WARN "CBIND: ILLEGAL ARGUMENT" (CAR Z)))
((NULL *LAST*)
(WARN "CBIND: NOTHING ADDED YET" (CAR Z)))
(T (MAKE-CE-VAR-BIND (CAR Z)
*LAST*)))))
(BIND
(NLAMBDA Z (* JonL "23-Apr-84 19:12")
(PROG (VAL)
(COND
((NOT *IN-RHS*)
(WARN "CANNOT BE CALLED AT TOP LEVEL" (QUOTE BIND))
(RETURN NIL)))
(COND
((< (LENGTH Z)
1)
(WARN "BIND: WRONG NUMBER OF ARGUMENTS TO" Z)
(RETURN NIL))
((NOT (SYMBOLP (CAR Z)))
(WARN "BIND: ILLEGAL ARGUMENT" (CAR Z))
(RETURN NIL))
((==(LENGTH Z)
1)
(SETQ VAL (GENSYM)))
(T ($RESET)
(EVAL-ARGS (CDR Z))
(SETQ VAL ($PARAMETER 1))))
(MAKE-VAR-BIND (CAR Z)
VAL))))
(MODIFY
[NLAMBDA Z
(PROG (OLD)
(COND
((NOT *IN-RHS*)
(WARN "CANNOT BE CALLED AT TOP LEVEL" (QUOTE MODIFY))
(RETURN NIL)))
(SETQ OLD (GET-CE-VAR-BIND (CAR Z)))
(COND
((NULL OLD)
(WARN "MODIFY: FIRST ARGUMENT MUST BE AN ELEMENT VARIABLE" (CAR Z))
(RETURN NIL)))
(REMOVE-FROM-WM OLD)
(SETQ Z (CDR Z))
($RESET)
COPY(AND (ATOM OLD)
(GO FIN))
($CHANGE (CAR OLD))
(SETQ OLD (CDR OLD))
(GO COPY)
FIN (EVAL-ARGS Z)
($ASSERT])
(MAKE
[NLAMBDA Z
(PROG NIL
($RESET)
(EVAL-ARGS Z)
($ASSERT])
($PARAMETER
(LAMBDA (K) (* JonL "23-Apr-84 19:06")
(COND
((OR (NOT (NUMBERP K))
(> K *SIZE-RESULT-ARRAY*)
(< K 1))
(WARN "ILLEGAL PARAMETER NUMBER " K)
NIL)
((> K *MAX-INDEX*)
NIL)
(T (GETVECTOR *RESULT-ARRAY* K)))))
($PARAMETERCOUNT
[LAMBDA NIL *MAX-INDEX*])
($ASSERT
[LAMBDA NIL
(SETQ *LAST*(USE-RESULT-ARRAY))
(ADD-TO-WM *LAST* NIL])
(USE-RESULT-ARRAY
[LAMBDA NIL (* edited: "17-Feb-84 10:11")
(PROG (K R)
(SETQ K *MAX-INDEX*)
(SETQ R NIL)
TOP (AND (== K 0)
(RETURN R))
(SETQ R (CONS (GETVECTOR *RESULT-ARRAY* K)
R))
(SETQ K (SUB1 K))
(GO TOP])
($VALUE
(LAMBDA (V) (* JonL "23-Apr-84 19:06")
(COND
((> *NEXT-INDEX* *SIZE-RESULT-ARRAY*)
(WARN "INDEX TOO LARGE" *NEXT-INDEX*))
(T (AND (> *NEXT-INDEX* *MAX-INDEX*)
(SETQ *MAX-INDEX* *NEXT-INDEX*))
(PUTVECTOR *RESULT-ARRAY* *NEXT-INDEX* V)
(SETQ *NEXT-INDEX* (IPLUS 1 *NEXT-INDEX*))))))
($TAB
(LAMBDA (Z) (* JonL "23-Apr-84 19:06")
(PROG (EDGE NEXT)
(SETQ NEXT ($LITBIND Z))
(AND (FLOATP NEXT)
(SETQ NEXT (FIX NEXT)))
(COND
((OR (NOT (NUMBERP NEXT))
(> NEXT *SIZE-RESULT-ARRAY*)
(> 1 NEXT))
(WARN "ILLEGAL INDEX AFTER ↑" NEXT)
(RETURN *NEXT-INDEX*)))
(SETQ EDGE (- NEXT 1))
(COND
((> *MAX-INDEX* EDGE)
(GO OK)))
CLEAR
(COND
((== *MAX-INDEX* EDGE)
(GO OK)))
(PUTVECTOR *RESULT-ARRAY* EDGE NIL)
(SETQ EDGE (1- EDGE))
(GO CLEAR)
OK (SETQ *NEXT-INDEX* NEXT)
(RETURN NEXT))))
(RHS-TAB
[LAMBDA (Z)
($TAB ($VARBIND Z])
($RESET
(LAMBDA NIL (* JonL "15-Feb-84 14:42")
(SETQ *MAX-INDEX* 0)
(SETQ *NEXT-INDEX* 1)))
(EVAL-FUNCTION
[LAMBDA (FORM) (* edited: "17-Feb-84 10:52")
(COND
((NOT *IN-RHS*)
(WARN "FUNCTIONS CANNOT BE USED AT TOP LEVEL" (CAR FORM)))
(T (EVAL FORM])
(EVAL-ARGS
[LAMBDA (Z) (* edited: "17-Feb-84 15:08")
(PROG (R)
(RHS-TAB 1)
LA (AND (ATOM Z)
(RETURN NIL))
(SETQ R (CAR Z))
(SETQ Z (CDR Z))
[COND
((EQ R (QUOTE ↑))
(RHS-TAB (CAR Z))
(SETQ R (CADR Z))
(SETQ Z (CDDR Z]
(COND
((EQ R (QUOTE //))
($VALUE (CAR Z))
(SETQ Z (CDR Z)))
(T ($CHANGE R)))
(GO LA])
($CHANGE
(LAMBDA (X) (* JonL "23-Apr-84 19:44")
(PROG NIL
(COND
((DTPR X)
(EVAL-FUNCTION X))
(T ($VALUE ($VARBIND X)))))))
(UNFLAT*
[LAMBDA NIL (* edited: "16-Feb-84 12:14")
(PROG (C)
(COND
((ATOM *REST*)
(RETURN NIL)))
(SETQ C (CAR *REST*))
(SETQ *REST* (CDR *REST*))
(COND
[(EQ C "(")
(RETURN (CONS (UNFLAT*)
(UNFLAT*]
((EQ C ")")
(RETURN NIL))
(T (RETURN (CONS C (UNFLAT*])
(UNFLAT
[LAMBDA (X)
(SETQ *REST* X)
(UNFLAT*])
(BUILD-COLLECT
(LAMBDA (Z) (* JonL "23-Apr-84 19:44")
(PROG (R)
LA (AND (ATOM Z)
(RETURN NIL))
(SETQ R (CAR Z))
(SETQ Z (CDR Z))
(COND
((DTPR R)
($VALUE "(")
(BUILD-COLLECT R)
($VALUE ")"))
((EQ R (QUOTE //))
($CHANGE (CAR Z))
(SETQ Z (CDR Z)))
(T ($VALUE R)))
(GO LA))))
(GET-NUM-CE
(LAMBDA (X) (* JonL "23-Apr-84 19:06")
(PROG (R L D)
(SETQ R *DATA-MATCHED*)
(SETQ L (LENGTH R))
(SETQ D (- L X))
(AND (> 0 D)
(RETURN NIL))
LA (COND
((NULL R)
(RETURN NIL))
((> 1 D)
(RETURN (CAR R))))
(SETQ D (1- D))
(SETQ R (CDR R))
(GO LA))))
(GET-CE-VAR-BIND
[LAMBDA (X)
(PROG (R)
[COND
((NUMBERP X)
(RETURN (GET-NUM-CE X]
(SETQ R (ASSQ X *CE-VARIABLE-MEMORY*))
(COND
(R (RETURN (CDR R)))
(T (RETURN NIL])
(ASSQ
(LAMBDA (X Y) (* JonL "15-Feb-84 11:41")
(ASSOC X Y)))
($VARBIND
[LAMBDA (X)
(PROG (R)
(AND (NOT *IN-RHS*)
(RETURN X))
(SETQ R (ASSQ X *VARIABLE-MEMORY*))
(COND
(R (RETURN (CDR R)))
(T (RETURN X])
(MAKE-VAR-BIND
[LAMBDA (VAR ELEM)
(SETQ *VARIABLE-MEMORY*(CONS (CONS VAR ELEM)*VARIABLE-MEMORY*])
(MAKE-CE-VAR-BIND
[LAMBDA (VAR ELEM)
(SETQ *CE-VARIABLE-MEMORY*(CONS (CONS VAR ELEM)*CE-VARIABLE-MEMORY*])
(INIT-CE-VAR-MEM
[LAMBDA (VLIST)
(PROG (V IND R)
(SETQ *CE-VARIABLE-MEMORY* NIL)
TOP (AND (ATOM VLIST)
(RETURN NIL))
(SETQ V (CAR VLIST))
(SETQ IND (CADR VLIST))
(SETQ VLIST (CDDR VLIST))
(SETQ R (CE-GELM *DATA-MATCHED* IND))
(SETQ *CE-VARIABLE-MEMORY*(CONS (CONS V R)*CE-VARIABLE-MEMORY*))
(GO TOP])
(INIT-VAR-MEM
[LAMBDA (VLIST)
(PROG (V IND R)
(SETQ *VARIABLE-MEMORY* NIL)
TOP (AND (ATOM VLIST)
(RETURN NIL))
(SETQ V (CAR VLIST))
(SETQ IND (CADR VLIST))
(SETQ VLIST (CDDR VLIST))
(SETQ R (GELM *DATA-MATCHED* IND))
(SETQ *VARIABLE-MEMORY*(CONS (CONS V R)*VARIABLE-MEMORY*))
(GO TOP])
(TIME-TAG-PRINT
[LAMBDA (DATA PORT) (* edited: "16-Feb-84 12:07")
(COND
((NOT (NULL DATA))
(TIME-TAG-PRINT (CDR DATA)
PORT)
(PRIN1 " " PORT)
(PRIN1 (CREATION-TIME (CAR DATA))
PORT])
(EVAL-RHS
[LAMBDA (PNAME DATA) (* pkh: "13-Feb-84 14:12")
(PROG (NODE PORT)
(COND
(*PTRACE* (SETQ PORT (TRACE-FILE))
(TERPRI PORT)
(PRIN1 *CYCLE-COUNT* PORT)
(PRIN1 (QUOTE %|)
PORT)
(PRIN1 PNAME PORT)
(TIME-TAG-PRINT DATA PORT)))
(SETQ *DATA-MATCHED* DATA)
(SETQ *P-NAME* PNAME)
(SETQ *LAST* NIL)
(SETQ NODE (GET PNAME (QUOTE TOPNODE)))
(INIT-VAR-MEM (VAR-PART NODE))
(INIT-CE-VAR-MEM (CE-VAR-PART NODE))
(BEGIN-RECORD PNAME DATA)
(SETQ *IN-RHS* T)
(EVAL (RHS-PART NODE))
(SETQ *IN-RHS* NIL)
(END-RECORD])
(TRACE-FILE
[LAMBDA NIL
(PROG (PORT)
(SETQ PORT T)
[COND
(*TRACE-FILE* (SETQ PORT ($OFILE *TRACE-FILE*))
(COND
((NULL PORT)
(WARN "TRACE: FILE HAS BEEN CLOSED" *TRACE-FILE*)
(SETQ PORT T]
(RETURN PORT])
(REFRESH-ADD
[LAMBDA (X)
(ADD-TO-WM (CAR X)
(CDR X])
(REFRESH-DEL
[LAMBDA (X)
(REMOVE-FROM-WM (CAR X])
(REFRESH-COLLECT
[LAMBDA (X)
(SETQ *OLD-WM*(CONS X *OLD-WM*])
(REFRESH
[LAMBDA NIL (* edited: "10-Feb-84 12:45")
(PROG NIL
(SETQ *OLD-WM* NIL)
(MAPWM (FUNCTION REFRESH-COLLECT))
(MAPC *OLD-WM* (FUNCTION REFRESH-DEL))
(MAPC *OLD-WM* (FUNCTION REFRESH-ADD))
(SETQ *OLD-WM* NIL])
(CREATION-TIME
[LAMBDA (WME)
(CDR (ASSQ WME (GET (WM-HASH WME)
(QUOTE WMPART*])
(WM-HASH
(LAMBDA (X) (* JonL "15-Feb-84 11:17")
(COND
((NOT X)
(QUOTE <DEFAULT>))
((NOT (CAR X))
(WM-HASH (CDR X)))
((SYMBOLP (CAR X))
(CAR X))
(T (WM-HASH (CDR X))))))
(GET-WM2
[LAMBDA (ELEM)
(COND
((OR (NULL *WM-FILTER*)
(MEMBER (CDR ELEM)*WM-FILTER*))
(SETQ *WM*(CONS (CAR ELEM)*WM*])
(GET-WM
[LAMBDA (Z)
(SETQ *WM-FILTER* Z)
(SETQ *WM* NIL)
(MAPWM (FUNCTION GET-WM2))
(PROG2 NIL *WM*(SETQ *WM* NIL])
(WM
(NLAMBDA A (* JonL "15-Feb-84 11:38")
(MAPC (GET-WM A)
(FUNCTION (LAMBDA (Z)
(TERPRI T)
(PPELM Z T))))
(TERPRI T)
NIL))
(MAPWM
[LAMBDA (FN) (* edited: "10-Feb-84 12:46")
(PROG (WMPL PART)
(SETQ WMPL *WMPART-LIST*)
LAB1(COND
((ATOM WMPL)
(RETURN NIL)))
(SETQ PART (GET (CAR WMPL)
(QUOTE WMPART*)))
(SETQ WMPL (CDR WMPL))
(MAPC PART FN)
(GO LAB1])
(REMOVE-FROM-WM
[LAMBDA (WME) (* edited: "16-Feb-84 12:04")
(PROG (FA Z PART TIMETAG PORT)
(SETQ FA (WM-HASH WME))
(SETQ PART (GET FA (QUOTE WMPART*)))
(SETQ Z (ASSQ WME PART))
(OR Z (RETURN NIL))
(SETQ TIMETAG (CDR Z))
(COND
((AND *WTRACE* *IN-RHS*)
(SETQ PORT (TRACE-FILE))
(TERPRI PORT)
(PRIN1 "<=WM: " PORT)
(PPELM WME PORT)))
(SETQ *ACTION-COUNT* (IPLUS 1 *ACTION-COUNT*))
(SETQ *CRITICAL* T)
(SETQ *CURRENT-WM* (1- *CURRENT-WM*))
(RECORD-CHANGE (QUOTE <=WM)
TIMETAG WME)
(MATCH NIL WME)
(PUTPROP FA (QUOTE WMPART*)
(DREMOVE Z PART))
(SETQ *CRITICAL* NIL])
(ADD-TO-WM
(LAMBDA (WME OVERRIDE) (* JonL "23-Apr-84 19:06")
(PROG (FA Z PART TIMETAG PORT)
(SETQ *CRITICAL* T)
(SETQ *CURRENT-WM* (IPLUS 1 *CURRENT-WM*))
(AND (> *CURRENT-WM* *MAX-WM*)
(SETQ *MAX-WM* *CURRENT-WM*))
(SETQ *ACTION-COUNT* (IPLUS 1 *ACTION-COUNT*))
(SETQ FA (WM-HASH WME))
(OR (MEMQ FA *WMPART-LIST*)
(SETQ *WMPART-LIST* (CONS FA *WMPART-LIST*)))
(SETQ PART (GET FA (QUOTE WMPART*)))
(COND
(OVERRIDE (SETQ TIMETAG OVERRIDE))
(T (SETQ TIMETAG *ACTION-COUNT*)))
(SETQ Z (CONS WME TIMETAG))
(PUTPROP FA (QUOTE WMPART*)
(CONS Z PART))
(RECORD-CHANGE (QUOTE =>WM)
*ACTION-COUNT* WME)
(MATCH (QUOTE NEW)
WME)
(SETQ *CRITICAL* NIL)
(COND
((AND *IN-RHS* *WTRACE*)
(SETQ PORT (TRACE-FILE))
(TERPRI PORT)
(PRIN1 "=>WM: " PORT)
(PPELM WME PORT))))))
(CONCAT-AMOS
[LAMBDA (A B C) (* edited: "10-Feb-84 10:53")
(MKATOM (CONCAT A B C])
(CONFLICT-SET
(LAMBDA NIL (* JonL "23-Apr-84 19:06")
(PROG (CNTS CS P Z BEST)
(SETQ CNTS NIL)
(SETQ CS *CONFLICT-SET*)
L1: (AND (ATOM CS)
(GO L2:))
(SETQ P (CAAAR CS))
(SETQ CS (CDR CS))
(SETQ Z (ASSQ P CNTS))
(COND
((NULL Z)
(SETQ CNTS (CONS (CONS P 1)
CNTS)))
(T (RPLACD Z (1+ (CDR Z)))))
(GO L1:)
L2: (COND
((ATOM CNTS)
(SETQ BEST (BEST-OF *CONFLICT-SET*))
(TERPRI)
(RETURN (LIST (CAAR BEST)
(QUOTE DOMINATES)))))
(TERPRI)
(PRIN1 (CAAR CNTS))
(COND
((> (CDAR CNTS)
1)
(PRIN1 " (")
(PRIN1 (CDAR CNTS))
(PRIN1 " OCCURRENCES )")))
(SETQ CNTS (CDR CNTS))
(GO L2:))))
(CONFLICT-SET-COMPARE
(LAMBDA (X Y) (* JonL "23-Apr-84 19:06")
(PROG (XORDER YORDER XL YL XV YV)
(SETQ XORDER (ORDER-PART X))
(SETQ YORDER (ORDER-PART Y))
(SETQ XL (CAR XORDER))
(SETQ YL (CAR YORDER))
DATA(COND
((AND (NULL XL)
(NULL YL))
(GO PS))
((NULLA YL)
(RETURN T))
((NULLA XL)
(RETURN NIL)))
(SETQ XV (CAR XL))
(SETQ YV (CAR YL))
(COND
((> XV YV)
(RETURN T))
((> YV XV)
(RETURN NIL)))
(SETQ XL (CDR XL))
(SETQ YL (CDR YL))
(GO DATA)
PS (SETQ XL (CDR XORDER))
(SETQ YL (CDR YORDER))
PSL (COND
((NULL XL)
(RETURN T)))
(SETQ XV (CAR XL))
(SETQ YV (CAR YL))
(COND
((> XV YV)
(RETURN T))
((> YV XV)
(RETURN NIL)))
(SETQ XL (CDR XL))
(SETQ YL (CDR YL))
(GO PSL))))
(INSTANTIATION
[LAMBDA (CONFLICT-ELEM)
(CDR (PNAME-INSTANTIATION CONFLICT-ELEM])
(ORDER-PART
[LAMBDA (CONFLICT-ELEM)
(CDR CONFLICT-ELEM])
(PNAME-INSTANTIATION
[LAMBDA (CONFLICT-ELEM)
(CAR CONFLICT-ELEM])
(REMOVE-FROM-CONFLICT-SET
[LAMBDA (NAME) (* edited: "10-Feb-84 11:49")
(PROG (CS ENTRY)
L1 (SETQ CS *CONFLICT-SET*)
L2 (COND
((ATOM CS)
(RETURN NIL)))
(SETQ ENTRY (CAR CS))
(SETQ CS (CDR CS))
(COND
((EQ NAME (CAAR ENTRY))
(SETQ *CONFLICT-SET*(DREMOVE ENTRY *CONFLICT-SET*))
(GO L1))
(T (GO L2])
(BEST-OF*
[LAMBDA (BEST REM)
(COND
((NOT REM)
BEST)
((CONFLICT-SET-COMPARE BEST (CAR REM))
(BEST-OF* BEST (CDR REM)))
(T (BEST-OF* (CAR REM)
(CDR REM])
(BEST-OF
[LAMBDA (SET)
(BEST-OF* (CAR SET)
(CDR SET])
(CONFLICT-RESOLUTION
(LAMBDA NIL (* JonL "23-Apr-84 19:06")
(PROG (BEST LEN)
(SETQ LEN (LENGTH *CONFLICT-SET*))
(COND
((> LEN *MAX-CS*)
(SETQ *MAX-CS* LEN)))
(SETQ *TOTAL-CS* (+ *TOTAL-CS* LEN))
(COND
(*CONFLICT-SET* (SETQ BEST (BEST-OF *CONFLICT-SET*))
(SETQ *CONFLICT-SET* (DREMOVE BEST *CONFLICT-SET*))
(RETURN (PNAME-INSTANTIATION BEST)))
(T (RETURN NIL))))))
(DSORT
(LAMBDA (X) (* JonL "23-Apr-84 19:06")
(PROG (SORTED CUR NEXT CVAL NVAL)
(AND (ATOM (CDR X))
(RETURN X))
LOOP(SETQ SORTED T)
(SETQ CUR X)
(SETQ NEXT (CDR X))
CHEK(SETQ CVAL (CAR CUR))
(SETQ NVAL (CAR NEXT))
(COND
((> NVAL CVAL)
(SETQ SORTED NIL)
(RPLACA CUR NVAL)
(RPLACA NEXT CVAL)))
(SETQ CUR NEXT)
(SETQ NEXT (CDR CUR))
(COND
((NOT (NULL NEXT))
(GO CHEK))
(SORTED (RETURN X))
(T (GO LOOP))))))
(ORDER-TAGS
[LAMBDA (DAT)
(PROG (TAGS)
(SETQ TAGS NIL)
L1: (AND (ATOM DAT)
(GO L2:))
(SETQ TAGS (CONS (CREATION-TIME (CAR DAT))
TAGS))
(SETQ DAT (CDR DAT))
(GO L1:)
L2: (COND
[(EQ *STRATEGY* (QUOTE MEA))
(RETURN (CONS (CAR TAGS)
(DSORT (CDR TAGS]
(T (RETURN (DSORT TAGS])
(INSERTCS
[LAMBDA (NAME DATA RATING)
(PROG (INSTAN)
(AND (REFRACTED NAME DATA)
(RETURN NIL))
(SETQ INSTAN (LIST (CONS NAME DATA)
(ORDER-TAGS DATA)
RATING))
(AND (ATOM *CONFLICT-SET*)
(SETQ *CONFLICT-SET* NIL))
(RETURN (SETQ *CONFLICT-SET*(CONS INSTAN *CONFLICT-SET*])
(REMOVECS
[LAMBDA (NAME DATA) (* edited: "10-Feb-84 11:51")
(PROG (CR-DATA INST CS)
(SETQ CR-DATA (CONS NAME DATA))
(SETQ CS *CONFLICT-SET*)
L: (COND
((NULL CS)
(RECORD-REFRACT NAME DATA)
(RETURN NIL)))
(SETQ INST (CAR CS))
(SETQ CS (CDR CS))
(AND (NOT (TOP-LEVELS-EQ (CAR INST)
CR-DATA))
(GO L:))
(SETQ *CONFLICT-SET*(DREMOVE INST *CONFLICT-SET*])
(REMOVE-OLD-NO-NUM
[LAMBDA (LIS DATA)
(PROG (M NEXT LAST)
(SETQ M (CAR LIS))
[COND
((ATOM M)
(RETURN NIL))
((TOP-LEVELS-EQ DATA (CAR M))
(SETQ *CURRENT-TOKEN* (1- *CURRENT-TOKEN*))
(RPLACA LIS (CDR M))
(RETURN (CAR M]
(SETQ NEXT M)
LOOP(SETQ LAST NEXT)
(SETQ NEXT (CDR NEXT))
(COND
((ATOM NEXT)
(RETURN NIL))
((TOP-LEVELS-EQ DATA (CAR NEXT))
(RPLACD LAST (CDR NEXT))
(SETQ *CURRENT-TOKEN* (1- *CURRENT-TOKEN*))
(RETURN (CAR NEXT)))
(T (GO LOOP])
(REMOVE-OLD-NUM
[LAMBDA (LIS DATA)
(PROG (M NEXT LAST)
(SETQ M (CAR LIS))
[COND
((ATOM M)
(RETURN NIL))
((TOP-LEVELS-EQ DATA (CAR M))
(SETQ *CURRENT-TOKEN* (1- *CURRENT-TOKEN*))
(RPLACA LIS (CDDR M))
(RETURN (CAR M]
(SETQ NEXT M)
LOOP(SETQ LAST NEXT)
(SETQ NEXT (CDDR NEXT))
(COND
((ATOM NEXT)
(RETURN NIL))
((TOP-LEVELS-EQ DATA (CAR NEXT))
(RPLACD (CDR LAST)
(CDDR NEXT))
(SETQ *CURRENT-TOKEN* (1- *CURRENT-TOKEN*))
(RETURN (CAR NEXT)))
(T (GO LOOP])
(REMOVE-OLD
[LAMBDA (LIS DATA NUM)
(COND
(NUM (REMOVE-OLD-NUM LIS DATA))
(T (REMOVE-OLD-NO-NUM LIS DATA])
(REAL-ADD-TOKEN
[LAMBDA (LIS DATA-PART NUM)
(SETQ *CURRENT-TOKEN* (IPLUS 1 *CURRENT-TOKEN*))
[COND
(NUM (RPLACA LIS (CONS NUM (CAR LIS]
(RPLACA LIS (CONS DATA-PART (CAR LIS])
(ADD-TOKEN
[LAMBDA (MEMLIS FLAG DATA-PART NUM) (* edited: "16-Feb-84 11:57")
(PROG (WAS-PRESENT)
(COND
((EQ FLAG (QUOTE NEW))
(SETQ WAS-PRESENT NIL)
(REAL-ADD-TOKEN MEMLIS DATA-PART NUM))
((NOT FLAG)
(SETQ WAS-PRESENT (REMOVE-OLD MEMLIS DATA-PART NUM)))
((EQ FLAG (QUOTE OLD))
(SETQ WAS-PRESENT T)))
(RETURN WAS-PRESENT])
(NOT-RIGHT
(LAMBDA (OUTS MEM TESTS) (* JonL "23-Apr-84 19:49")
(PROG (FP DP MEMDP TLIST TST LIND RIND RES NEWFP INC NEWC)
(SETQ FP *FLAG-PART*)
(SETQ DP *DATA-PART*)
(COND
((NOT FP)
(SETQ INC -1)
(SETQ NEWFP (QUOTE NEW)))
((EQ FP (QUOTE NEW))
(SETQ INC 1)
(SETQ NEWFP NIL))
(T (RETURN NIL)))
FAIL(AND (NULL MEM)
(RETURN NIL))
(SETQ MEMDP (CAR MEM))
(SETQ NEWC (CADR MEM))
(SETQ TLIST TESTS)
TLOOP
(AND (NULL TLIST)
(GO SUCC))
(SETQ TST (CAR TLIST))
(SETQ TLIST (CDR TLIST))
(SETQ LIND (CAR TLIST))
(SETQ TLIST (CDR TLIST))
(SETQ RIND (CAR TLIST))
(SETQ TLIST (CDR TLIST))
(COMMENT THE NEXT LINE DIFFERS IN NOT-LEFT & -RIGHT)
(SETQ RES (APPLY* TST (GELM DP RIND)
(GELM MEMDP LIND)))
(COND
(RES (GO TLOOP))
(T (SETQ MEM (CDDR MEM))
(GO FAIL)))
SUCC(SETQ NEWC (+ INC NEWC))
(RPLACA (CDR MEM)
NEWC)
(COND
((OR (AND (== INC -1)
(== NEWC 0))
(AND (== INC 1)
(== NEWC 1)))
(SENDTO NEWFP MEMDP (QUOTE RIGHT)
OUTS)))
(SETQ MEM (CDDR MEM))
(GO FAIL))))
(NOT-LEFT
(LAMBDA (OUTS MEM TESTS OWN-MEM) (* JonL "23-Apr-84 19:22")
(PROG (FP DP MEMDP TLIST TST LIND RIND RES C)
(SETQ FP *FLAG-PART*)
(SETQ DP *DATA-PART*)
(SETQ C 0)
FAIL(AND (NULL MEM)
(GO FIN))
(SETQ MEMDP (CAR MEM))
(SETQ MEM (CDR MEM))
(SETQ TLIST TESTS)
TLOOP
(AND (NULL TLIST)
(SETQ C (1+ C))
(GO FAIL))
(SETQ TST (CAR TLIST))
(SETQ TLIST (CDR TLIST))
(SETQ LIND (CAR TLIST))
(SETQ TLIST (CDR TLIST))
(SETQ RIND (CAR TLIST))
(SETQ TLIST (CDR TLIST))
(COMMENT THE NEXT LINE DIFFERS IN NOT-LEFT & -RIGHT)
(SETQ RES (APPLY* TST (GELM MEMDP RIND)
(GELM DP LIND)))
(COND
(RES (GO TLOOP))
(T (GO FAIL)))
FIN (ADD-TOKEN OWN-MEM FP DP C)
(AND (== C 0)
(SENDTO FP DP (QUOTE LEFT)
OUTS)))))
(&NOT
[LAMBDA (OUTS LMEM RPRED TESTS) (* edited: "16-Feb-84 11:56")
(COND
((AND (EQ *SIDE* (QUOTE RIGHT))
(EQ *FLAG-PART* (QUOTE OLD)))
NIL)
((EQ *SIDE* (QUOTE RIGHT))
(NOT-RIGHT OUTS (CAR LMEM)
TESTS))
(T (NOT-LEFT OUTS (MEMORY-PART RPRED)
TESTS LMEM])
(&OLD
[LAMBDA (A B C D E)
NIL])
(&P
[LAMBDA (RATING NAME VAR-DOPE CE-VAR-DOPE RHS)
(PROG (FP DP)
(COND
(*SENDTOCALL* (SETQ FP *FLAG-PART*)
(SETQ DP *DATA-PART*))
(T (SETQ FP *ALPHA-FLAG-PART*)
(SETQ DP *ALPHA-DATA-PART*)))
(AND (MEMQ FP (QUOTE (NIL OLD)))
(REMOVECS NAME DP))
(AND FP (INSERTCS NAME DP RATING])
(TXXB
[LAMBDA (NEW EQVAR)
(COND
((NUMBERP NEW)
(COND
((NUMBERP EQVAR)
T)
(T NIL)))
(T (COND
((NUMBERP EQVAR)
NIL)
(T T])
(TLEB
[LAMBDA (NEW EQVAR)
(COND
((NOT (NUMBERP NEW))
NIL)
((NOT (NUMBERP EQVAR))
NIL)
((NOT (GREATERP NEW EQVAR))
T)
(T NIL])
(TGEB
[LAMBDA (NEW EQVAR)
(COND
((NOT (NUMBERP NEW))
NIL)
((NOT (NUMBERP EQVAR))
NIL)
((NOT (GREATERP EQVAR NEW))
T)
(T NIL])
(TGTB
[LAMBDA (NEW EQVAR)
(COND
((NOT (NUMBERP NEW))
NIL)
((NOT (NUMBERP EQVAR))
NIL)
((GREATERP NEW EQVAR)
T)
(T NIL])
(TLTB
[LAMBDA (NEW EQVAR)
(COND
((NOT (NUMBERP NEW))
NIL)
((NOT (NUMBERP EQVAR))
NIL)
((GREATERP EQVAR NEW)
T)
(T NIL])
(TNEB
(LAMBDA (NEW EQVAR) (* JonL "23-Apr-84 19:06")
(COND
((EQ NEW EQVAR)
NIL)
((NOT (NUMBERP NEW))
T)
((NOT (NUMBERP EQVAR))
T)
((=ALG NEW EQVAR)
NIL)
(T T))))
(TEQB
(LAMBDA (NEW EQVAR) (* JonL "23-Apr-84 19:06")
(COND
((EQ NEW EQVAR)
T)
((NOT (NUMBERP NEW))
NIL)
((NOT (NUMBERP EQVAR))
NIL)
((=ALG NEW EQVAR)
T)
(T NIL))))
(AND-RIGHT
[LAMBDA (OUTS MEM TESTS) (* edited: " 9-Feb-84 19:32")
(PROG (FP DP MEMDP TLIST TST LIND RIND RES)
(SETQ FP *FLAG-PART*)
(SETQ DP *DATA-PART*)
FAIL(AND (NULL MEM)
(RETURN NIL))
(SETQ MEMDP (CAR MEM))
(SETQ MEM (CDR MEM))
(SETQ TLIST TESTS)
TLOOP
(AND (NULL TLIST)
(GO SUCC))
(SETQ TST (CAR TLIST))
(SETQ TLIST (CDR TLIST))
(SETQ LIND (CAR TLIST))
(SETQ TLIST (CDR TLIST))
(SETQ RIND (CAR TLIST))
(SETQ TLIST (CDR TLIST))
(COMMENT THE NEXT LINE DIFFERS IN AND-LEFT & -RIGHT)
(SETQ RES (APPLY* TST (GELM DP RIND)
(GELM MEMDP LIND)))
(COND
(RES (GO TLOOP))
(T (GO FAIL)))
SUCC(COMMENT THE NEXT LINE DIFFERS IN AND-LEFT & -RIGHT)
(SENDTO FP (CONS (CAR DP)
MEMDP)
(QUOTE RIGHT) OUTS)
(GO FAIL])
(AND-LEFT
[LAMBDA (OUTS MEM TESTS) (* edited: " 9-Feb-84 19:32")
(PROG (FP DP MEMDP TLIST TST LIND RIND RES)
(SETQ FP *FLAG-PART*)
(SETQ DP *DATA-PART*)
FAIL(AND (NULL MEM)
(RETURN NIL))
(SETQ MEMDP (CAR MEM))
(SETQ MEM (CDR MEM))
(SETQ TLIST TESTS)
TLOOP
(AND (NULL TLIST)
(GO SUCC))
(SETQ TST (CAR TLIST))
(SETQ TLIST (CDR TLIST))
(SETQ LIND (CAR TLIST))
(SETQ TLIST (CDR TLIST))
(SETQ RIND (CAR TLIST))
(SETQ TLIST (CDR TLIST))
(COMMENT THE NEXT LINE DIFFERS IN AND-LEFT & -RIGHT)
(SETQ RES (APPLY* TST (GELM MEMDP RIND)
(GELM DP LIND)))
(COND
(RES (GO TLOOP))
(T (GO FAIL)))
SUCC(COMMENT THE NEXT LINE DIFFERS IN AND-LEFT & -RIGHT)
(SENDTO FP (CONS (CAR MEMDP)
DP)
(QUOTE LEFT) OUTS)
(GO FAIL])
(&AND
[LAMBDA (OUTS LPRED RPRED TESTS) (* edited: "16-Feb-84 11:55")
(PROG (MEM)
[COND
((EQ *SIDE* (QUOTE RIGHT))
(SETQ MEM (MEMORY-PART LPRED)))
(T (SETQ MEM (MEMORY-PART RPRED]
(COND
((NOT MEM)
(RETURN NIL))
((EQ *SIDE* (QUOTE RIGHT))
(AND-RIGHT OUTS MEM TESTS))
(T (AND-LEFT OUTS MEM TESTS])
(&MEM
[LAMBDA (LEFT-OUTS RIGHT-OUTS MEMORY-LIST) (* edited: "16-Feb-84 11:54")
(PROG (FP DP)
(COND
(*SENDTOCALL* (SETQ FP *FLAG-PART*)
(SETQ DP *DATA-PART*))
(T (SETQ FP *ALPHA-FLAG-PART*)
(SETQ DP *ALPHA-DATA-PART*)))
(SENDTO FP DP (QUOTE LEFT)
LEFT-OUTS)
(ADD-TOKEN MEMORY-LIST FP DP NIL)
(SENDTO FP DP (QUOTE RIGHT)
RIGHT-OUTS])
(&TWO
[LAMBDA (LEFT-OUTS RIGHT-OUTS) (* edited: "16-Feb-84 11:54")
(PROG (FP DP)
(COND
(*SENDTOCALL* (SETQ FP *FLAG-PART*)
(SETQ DP *DATA-PART*))
(T (SETQ FP *ALPHA-FLAG-PART*)
(SETQ DP *ALPHA-DATA-PART*)))
(SENDTO FP DP (QUOTE LEFT)
LEFT-OUTS)
(SENDTO FP DP (QUOTE RIGHT)
RIGHT-OUTS])
(TLES
[LAMBDA (OUTS VARA VARB)
(PROG (A B)
(SETQ A (FAST-SYMEVAL VARA))
(SETQ B (FAST-SYMEVAL VARB))
(AND (NUMBERP A)
(NUMBERP B)
(NOT (GREATERP A B))
(EVAL-NODELIST OUTS])
(TGES
[LAMBDA (OUTS VARA VARB)
(PROG (A B)
(SETQ A (FAST-SYMEVAL VARA))
(SETQ B (FAST-SYMEVAL VARB))
(AND (NUMBERP A)
(NUMBERP B)
(NOT (GREATERP B A))
(EVAL-NODELIST OUTS])
(TGTS
[LAMBDA (OUTS VARA VARB)
(PROG (A B)
(SETQ A (FAST-SYMEVAL VARA))
(SETQ B (FAST-SYMEVAL VARB))
(AND (NUMBERP A)
(NUMBERP B)
(GREATERP A B)
(EVAL-NODELIST OUTS])
(TLTS
[LAMBDA (OUTS VARA VARB)
(PROG (A B)
(SETQ A (FAST-SYMEVAL VARA))
(SETQ B (FAST-SYMEVAL VARB))
(AND (NUMBERP A)
(NUMBERP B)
(GREATERP B A)
(EVAL-NODELIST OUTS])
(TXXS
[LAMBDA (OUTS VARA VARB)
(PROG (A B)
(SETQ A (FAST-SYMEVAL VARA))
(SETQ B (FAST-SYMEVAL VARB))
(COND
((AND (NUMBERP A)
(NUMBERP B))
(EVAL-NODELIST OUTS))
((AND (NOT (NUMBERP A))
(NOT (NUMBERP B)))
(EVAL-NODELIST OUTS])
(TNES
(LAMBDA (OUTS VARA VARB) (* JonL "23-Apr-84 19:06")
(PROG (A B)
(SETQ A (FAST-SYMEVAL VARA))
(SETQ B (FAST-SYMEVAL VARB))
(COND
((EQ A B)
(RETURN NIL))
((AND (NUMBERP A)
(NUMBERP B)
(=ALG A B))
(RETURN NIL))
(T (EVAL-NODELIST OUTS))))))
(TEQS
(LAMBDA (OUTS VARA VARB) (* JonL "23-Apr-84 19:06")
(PROG (A B)
(SETQ A (FAST-SYMEVAL VARA))
(SETQ B (FAST-SYMEVAL VARB))
(COND
((EQ A B)
(EVAL-NODELIST OUTS))
((AND (NUMBERP A)
(NUMBERP B)
(=ALG A B))
(EVAL-NODELIST OUTS))))))
(TLEN
[LAMBDA (OUTS REGISTER CONSTANT)
(PROG (Z)
(SETQ Z (FAST-SYMEVAL REGISTER))
(AND (NUMBERP Z)
(NOT (GREATERP Z CONSTANT))
(EVAL-NODELIST OUTS])
(TGEN
[LAMBDA (OUTS REGISTER CONSTANT)
(PROG (Z)
(SETQ Z (FAST-SYMEVAL REGISTER))
(AND (NUMBERP Z)
(NOT (GREATERP CONSTANT Z))
(EVAL-NODELIST OUTS])
(TGTN
[LAMBDA (OUTS REGISTER CONSTANT)
(PROG (Z)
(SETQ Z (FAST-SYMEVAL REGISTER))
(AND (NUMBERP Z)
(GREATERP Z CONSTANT)
(EVAL-NODELIST OUTS])
(TLTN
[LAMBDA (OUTS REGISTER CONSTANT)
(PROG (Z)
(SETQ Z (FAST-SYMEVAL REGISTER))
(AND (NUMBERP Z)
(GREATERP CONSTANT Z)
(EVAL-NODELIST OUTS])
(TXXN
[LAMBDA (OUTS REGISTER CONSTANT)
(PROG (Z)
(SETQ Z (FAST-SYMEVAL REGISTER))
(AND (NUMBERP Z)
(EVAL-NODELIST OUTS])
(TNEN
(LAMBDA (OUTS REGISTER CONSTANT) (* JonL "23-Apr-84 19:06")
(PROG (Z)
(SETQ Z (FAST-SYMEVAL REGISTER))
(AND (OR (NOT (NUMBERP Z))
(NOT (=ALG Z CONSTANT)))
(EVAL-NODELIST OUTS)))))
(TEQN
(LAMBDA (OUTS REGISTER CONSTANT) (* JonL "23-Apr-84 19:06")
(PROG (Z)
(SETQ Z (FAST-SYMEVAL REGISTER))
(AND (NUMBERP Z)
(=ALG Z CONSTANT)
(EVAL-NODELIST OUTS)))))
(TXXA
[LAMBDA (OUTS REGISTER CONSTANT)
(AND (SYMBOLP (FAST-SYMEVAL REGISTER))
(EVAL-NODELIST OUTS])
(TNEA
[LAMBDA (OUTS REGISTER CONSTANT)
(AND (NOT (EQ (FAST-SYMEVAL REGISTER)
CONSTANT))
(EVAL-NODELIST OUTS])
(TEQA
(LAMBDA (OUTS REGISTER CONSTANT)
(AND (EQ (FAST-SYMEVAL REGISTER)
CONSTANT)
(EVAL-NODELIST OUTS))))
(&ANY
(LAMBDA (OUTS REGISTER CONST-LIST) (* JonL "23-Apr-84 19:06")
(PROG (Z C)
(SETQ Z (FAST-SYMEVAL REGISTER))
(COND
((NUMBERP Z)
(GO NUMBER)))
SYMBOL
(COND
((NULL CONST-LIST)
(RETURN NIL))
((EQ (CAR CONST-LIST)
Z)
(GO OK))
(T (SETQ CONST-LIST (CDR CONST-LIST))
(GO SYMBOL)))
NUMBER
(COND
((NULL CONST-LIST)
(RETURN NIL))
((AND (NUMBERP (SETQ C (CAR CONST-LIST)))
(=ALG C Z))
(GO OK))
(T (SETQ CONST-LIST (CDR CONST-LIST))
(GO NUMBER)))
OK (EVAL-NODELIST OUTS))))
(&BUS
[LAMBDA (OUTS)
(PROG (DP)
(SETQ *ALPHA-FLAG-PART* *FLAG-PART*)
(SETQ *ALPHA-DATA-PART* *DATA-PART*)
(SETQ DP (CAR *DATA-PART*))
(SETQ *C1*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C2*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C3*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C4*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C5*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C6*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C7*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C8*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C9*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C10*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C11*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C12*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C13*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C14*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C15*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C16*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C17*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C18*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C19*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C20*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C21*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C22*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C23*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C24*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C25*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C26*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C27*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C28*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C29*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C30*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C31*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C32*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C33*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C34*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C35*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C36*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C37*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C38*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C39*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C40*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C41*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C42*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C43*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C44*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C45*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C46*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C47*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C48*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C49*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C50*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C51*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C52*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C53*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C54*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C55*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C56*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C57*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C58*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C59*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C60*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C61*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C62*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C63*(CAR DP))
(SETQ DP (CDR DP))
(SETQ *C64*(CAR DP))
(EVAL-NODELIST OUTS])
(SENDTO
[LAMBDA (FLAG DATA SIDE NL)
(PROG NIL
TOP (AND (NOT NL)
(RETURN NIL))
(SETQ *SIDE* SIDE)
(SETQ *FLAG-PART* FLAG)
(SETQ *DATA-PART* DATA)
(SETQ *SENDTOCALL* T)
(SETQ *LAST-NODE*(CAR NL))
(APPLY (CAAR NL)
(CDAR NL))
(SETQ NL (CDR NL))
(GO TOP])
(EVAL-NODELIST
[LAMBDA (NL) (* edited: "16-Feb-84 17:43")
(PROG NIL
TOP (AND (NOT NL)
(RETURN NIL))
(SETQ *SENDTOCALL* NIL)
(SETQ *LAST-NODE* (CAR NL))
(APPLY (CAAR NL)
(CDAR NL))
(SETQ NL (CDR NL))
(GO TOP])
(MATCH
[LAMBDA (FLAG WME)
(SENDTO FLAG (LIST WME)
(QUOTE LEFT)
(LIST *FIRST-NODE*])
(BETA-EQUIV
[LAMBDA (A B) (* edited: "16-Feb-84 11:52")
(AND (EQ (CAR A)
(CAR B))
(EQUAL (CDDDDR A)
(CDDDDR B))
(OR (EQ (CAR A)
(QUOTE &AND))
(EQUAL (CADDR A)
(CADDR B])
(EQUIV
[LAMBDA (A B)
(AND (EQ (CAR A)
(CAR B))
(OR (EQ (CAR A)
(QUOTE &MEM))
(EQ (CAR A)
(QUOTE &TWO))
(EQUAL (CADDR A)
(CADDR B)))
(EQUAL (CDDDR A)
(CDDDR B])
(FIND-EQUIV-BETA-NODE
[LAMBDA (NODE LIST)
(PROG (A)
(SETQ A LIST)
L1 [COND
((ATOM A)
(RETURN NIL))
((BETA-EQUIV NODE (CAR A))
(RETURN (CAR A]
(SETQ A (CDR A))
(GO L1])
(FIND-EQUIV-NODE
[LAMBDA (NODE LIST)
(PROG (A)
(SETQ A LIST)
L1 [COND
((ATOM A)
(RETURN NIL))
((EQUIV NODE (CAR A))
(RETURN (CAR A]
(SETQ A (CDR A))
(GO L1])
(LEFT-OUTS
[LAMBDA (NODE)
(CADR NODE])
(RIGHT-OUTS
[LAMBDA (NODE)
(CADDR NODE])
(ATTACH-LEFT
[LAMBDA (OLD NEW)
(RPLACA (CDR OLD)
(CONS NEW (CADR OLD])
(ATTACH-RIGHT
[LAMBDA (OLD NEW)
(RPLACA (CDDR OLD)
(CONS NEW (CADDR OLD])
(LINK-BOTH
(LAMBDA (LEFT RIGHT SUCC)
(PROG (A R)
(SETQ A (INTRQ (LEFT-OUTS LEFT)
(RIGHT-OUTS RIGHT)))
(SETQ R (FIND-EQUIV-BETA-NODE SUCC A))
(AND R (RETURN R))
(SETQ *REAL-CNT* (IPLUS 1 *REAL-CNT*))
(ATTACH-LEFT LEFT SUCC)
(ATTACH-RIGHT RIGHT SUCC)
(RETURN SUCC))))
(LINK-LEFT
[LAMBDA (PRED SUCC)
(PROG (A R)
(SETQ A (LEFT-OUTS PRED))
(SETQ R (FIND-EQUIV-NODE SUCC A))
(AND R (RETURN R))
(SETQ *REAL-CNT* (IPLUS 1 *REAL-CNT*))
(ATTACH-LEFT PRED SUCC)
(RETURN SUCC])
(LINK-NEW-BETA-NODE
(LAMBDA (R)
(SETQ *VIRTUAL-CNT* (IPLUS 1 *VIRTUAL-CNT*))
(SETQ *LAST-NODE* (LINK-BOTH *LAST-BRANCH* *LAST-NODE* R))
(SETQ *LAST-BRANCH* *LAST-NODE*)))
(LINK-TO-BRANCH
(LAMBDA (R)
(SETQ *VIRTUAL-CNT* (IPLUS 1 *VIRTUAL-CNT*))
(SETQ *LAST-BRANCH* (LINK-LEFT *LAST-BRANCH* R))))
(LINK-NEW-NODE
[LAMBDA (R)
[COND
([NOT (MEMBER (CAR R)
(QUOTE (&P &MEM &TWO &AND &NOT]
(SETQ *FEATURE-COUNT* (IPLUS 1 *FEATURE-COUNT*]
(SETQ *VIRTUAL-CNT* (IPLUS 1 *VIRTUAL-CNT*))
(SETQ *LAST-NODE* (LINK-LEFT *LAST-NODE* R])
(ENCODE-CE-DOPE
[LAMBDA NIL
(PROG (R ALL Z K)
(SETQ R NIL)
(SETQ ALL *CE-VARS*)
LA (AND (ATOM ALL)
(RETURN R))
(SETQ Z (CAR ALL))
(SETQ ALL (CDR ALL))
(SETQ K (CADR Z))
(SETQ R (CONS (CAR Z)
(CONS K R)))
(GO LA])
(ENCODE-DOPE
[LAMBDA NIL
(PROG (R ALL Z K)
(SETQ R NIL)
(SETQ ALL *VARS*)
LA (AND (ATOM ALL)
(RETURN R))
(SETQ Z (CAR ALL))
(SETQ ALL (CDR ALL))
(SETQ K (ENCODE-PAIR (CADR Z)
(CADDR Z)))
(SETQ R (CONS (CAR Z)
(CONS K R)))
(GO LA])
(MEMORY-PART
[LAMBDA (MEM-NODE)
(CAR (CADDDR MEM-NODE])
(PROTOMEM
[LAMBDA NIL
(LIST NIL])
(BUILD-BETA
[LAMBDA (TYPE TESTS) (* edited: "16-Feb-84 11:51")
(PROG (RPRED LPRED LNODE LEF)
(LINK-NEW-NODE (LIST (QUOTE &MEM)
NIL NIL (PROTOMEM)))
(SETQ RPRED *LAST-NODE*)
[COND
[(EQ TYPE (QUOTE &AND))
(SETQ LNODE (LIST (QUOTE &MEM)
NIL NIL (PROTOMEM]
(T (SETQ LNODE (LIST (QUOTE &TWO)
NIL NIL]
(SETQ LPRED (LINK-TO-BRANCH LNODE))
[COND
((EQ TYPE (QUOTE &AND))
(SETQ LEF LPRED))
(T (SETQ LEF (PROTOMEM]
(LINK-NEW-BETA-NODE (LIST TYPE NIL LEF RPRED TESTS])
(FUDGE*
(LAMBDA (Z)
(PROG (A)
(SETQ A (CDR Z))
(RPLACA A (IPLUS 1 (CAR A))))))
(FUDGE
[LAMBDA NIL (* edited: "10-Feb-84 12:50")
(MAPC *VARS* (FUNCTION FUDGE*))
(MAPC *CE-VARS* (FUNCTION FUDGE*])
(PROMOTE-VAR
(LAMBDA (DOPE) (* JonL "15-Feb-84 14:31")
(PROG (VNAME VPRED VPOS NEW)
(SETQ VNAME (CAR DOPE))
(SETQ VPRED (CADR DOPE))
(SETQ VPOS (CADDR DOPE))
(OR (EQ VPRED (QUOTE EQ))
(%%ERROR (QUOTE "ILLEGALPREDICATE FOR FIRST OCCURRENCE")
(LIST VNAME VPRED)))
(SETQ NEW (LIST VNAME 0 VPOS))
(SETQ *VARS* (CONS NEW *VARS*)))))
(ENCODE-SINGLETON
[LAMBDA (A)
(1- A])
(ENCODE-PAIR
(LAMBDA (A B) (* JonL "23-Apr-84 19:14")
(+ (ITIMES 10000 (1- A))
(1- B))))
(ADD-TEST
[LAMBDA (LIST NEW OLD) (* edited: "16-Feb-84 11:49")
(PROG (TTYPE LLOC RLOC)
(SETQ *FEATURE-COUNT* (IPLUS 1 *FEATURE-COUNT*))
(SETQ TTYPE (CONCAT-AMOS (QUOTE T)
(CADR NEW)
(QUOTE B)))
(SETQ RLOC (ENCODE-SINGLETON (CADDR NEW)))
(SETQ LLOC (ENCODE-PAIR (CADR OLD)
(CADDR OLD)))
(RETURN (CONS TTYPE (CONS LLOC (CONS RLOC LIST])
(CMP-BETA
(LAMBDA (KIND) (* JonL "15-Feb-84 14:29")
(PROG (TLIST VDOPE VNAME VPRED VPOS OLD)
(SETQ TLIST NIL)
LA (AND (ATOM *CUR-VARS*)
(GO LB))
(SETQ VDOPE (CAR *CUR-VARS*))
(SETQ *CUR-VARS* (CDR *CUR-VARS*))
(SETQ VNAME (CAR VDOPE))
(SETQ VPRED (CADR VDOPE))
(SETQ VPOS (CADDR VDOPE))
(SETQ OLD (ASSQ VNAME *VARS*))
(COND
(OLD (SETQ TLIST (ADD-TEST TLIST VDOPE OLD)))
((NEQ KIND (QUOTE &NOT))
(PROMOTE-VAR VDOPE)))
(GO LA)
LB (AND KIND (BUILD-BETA KIND TLIST))
(OR (EQ KIND (QUOTE &NOT))
(FUDGE))
(SETQ *LAST-BRANCH* *LAST-NODE*))))
(CMP-AND
[LAMBDA NIL (* edited: "16-Feb-84 11:48")
(CMP-BETA (QUOTE &AND])
(CMP-NOBETA
[LAMBDA NIL
(CMP-BETA NIL])
(CMP-NOT
[LAMBDA NIL (* edited: "16-Feb-84 11:48")
(CMP-BETA (QUOTE &NOT])
(CMP-CEVAR
(LAMBDA NIL (* JonL "23-Apr-84 19:41")
(PROG (NAME OLD)
(SETQ NAME (LEX))
(SETQ OLD (ASSQ NAME *CE-VARS*))
(AND OLD (%%ERROR "CONDITION ELEMENT VARIABLE USED TWICE" NAME))
(SETQ *CE-VARS* (CONS (LIST NAME 0)
*CE-VARS*)))))
(CMP-NEW-EQ-VAR
[LAMBDA (NAME OLD) (* edited: "10-Feb-84 12:24")
(PROG (PRED NEXT)
(SETQ *CUR-VARS* (DREMOVE OLD *CUR-VARS*))
(SETQ NEXT (ASSQ NAME *CUR-VARS*))
(COND
(NEXT (CMP-NEW-EQ-VAR NAME NEXT))
(T (CMP-NEW-VAR NAME (QUOTE EQ))))
(SETQ PRED (CADR OLD))
(LINK-NEW-NODE (LIST (CONCAT-AMOS (QUOTE T) PRED (QUOTE S))
NIL
(FIELD-NAME (CADDR OLD))
(CURRENT-FIELD])
(CMP-OLD-EQ-VAR
[LAMBDA (TEST OLD) (* edited: "16-Feb-84 11:47")
(LINK-NEW-NODE (LIST (CONCAT-AMOS (QUOTE T)
TEST
(QUOTE S))
NIL
(CURRENT-FIELD)
(FIELD-NAME (CADDR OLD])
(CMP-NEW-VAR
[LAMBDA (NAME TEST)
(SETQ *CUR-VARS*(CONS (LIST NAME TEST *SUBNUM*)*CUR-VARS*])
(CMP-VAR
[LAMBDA (TEST) (* edited: "16-Feb-84 11:47")
(PROG (OLD NAME)
(SETQ NAME (SUBLEX))
(SETQ OLD (ASSQ NAME *CUR-VARS*))
(COND
((AND OLD (EQ (CADR OLD)
(QUOTE EQ)))
(CMP-OLD-EQ-VAR TEST OLD))
((AND OLD (EQ TEST (QUOTE EQ)))
(CMP-NEW-EQ-VAR NAME OLD))
(T (CMP-NEW-VAR NAME TEST])
(CE-VAR-DOPE
[LAMBDA (VAR)
(ASSQ VAR *CE-VARS*])
(VAR-DOPE
[LAMBDA (VAR)
(ASSQ VAR *VARS*])
(FIELD-NAME
(LAMBDA (NUM) (* JonL "23-Apr-84 19:38")
(OR (AND (SMALLP NUM)
(> NUM 0)
(< NUM 65)
(PACK* (QUOTE *C)
NUM
(QUOTE *)))
(%%ERROR "CONDITION IS TOO LONG" (REST-OF-CE)))))
(CURRENT-FIELD
[LAMBDA NIL
(FIELD-NAME *SUBNUM*])
(CMP-NUMBER
[LAMBDA (TEST) (* edited: "16-Feb-84 11:46")
(LINK-NEW-NODE (LIST (CONCAT-AMOS (QUOTE T)
TEST
(QUOTE N))
NIL
(CURRENT-FIELD)
(SUBLEX])
(CMP-CONSTANT
[LAMBDA (TEST) (* edited: "16-Feb-84 11:45")
(OR (MEMQ TEST (QUOTE (EQ NE XX)))
(%%ERROR "NON-NUMERIC CONSTANT AFTER NUMERIC PREDICATE" (SUBLEX)))
(LINK-NEW-NODE (LIST (CONCAT-AMOS (QUOTE T)
TEST
(QUOTE A))
NIL
(CURRENT-FIELD)
(SUBLEX])
(CMP-SYMBOL
[LAMBDA (TEST) (* edited: "16-Feb-84 11:44")
(PROG (FLAG)
(SETQ FLAG T)
(COND
((EQ (PEEK-SUBLEX)
(QUOTE //))
(SUBLEX)
(SETQ FLAG NIL)))
(COND
((AND FLAG (VARIABLEP (PEEK-SUBLEX)))
(CMP-VAR TEST))
((NUMBERP (PEEK-SUBLEX))
(CMP-NUMBER TEST))
((SYMBOLP (PEEK-SUBLEX))
(CMP-CONSTANT TEST))
(T (%%ERROR "UNRECOGNIXED SYMBOL" (SUBLEX])
(VARIABLEP
(LAMBDA (X) (* JonL "15-Feb-84 12:08")
(AND (SYMBOLP X)
(EQ (GETCHAR X 1)
(QUOTE <)))))
(CMP-PRODUCT
[LAMBDA NIL (* edited: "16-Feb-84 11:44")
(PROG (SAVE)
(SETQ SAVE (REST-OF-CE))
(SUBLEX)
LA (COND
[(END-OF-CE)
(COND
((MEMBER (QUOTE })
SAVE)
(%%ERROR "WRONG CONTEXT FOR }" SAVE))
(T (%%ERROR "MISSING }" SAVE]
((EQ (PEEK-SUBLEX)
(QUOTE }))
(SUBLEX)
(RETURN NIL)))
(CMP-ATOMIC-OR-ANY)
(GO LA])
(CMP-ATOMIC
[LAMBDA NIL (* edited: "21-Feb-84 20:02")
(PROG (TEST X)
(SETQ X (PEEK-SUBLEX))
[COND
((EQ X (QUOTE =))
(SETQ TEST (QUOTE EQ))
(SUBLEX))
((EQ X (QUOTE <>))
(SETQ TEST (QUOTE NE))
(SUBLEX))
((EQ X (QUOTE <))
(SETQ TEST (QUOTE LT))
(SUBLEX))
((EQ X (QUOTE <=))
(SETQ TEST (QUOTE LE))
(SUBLEX))
((EQ X (QUOTE >))
(SETQ TEST (QUOTE GT))
(SUBLEX))
((EQ X (QUOTE >=))
(SETQ TEST (QUOTE GE))
(SUBLEX))
((EQ X (QUOTE <=>))
(SETQ TEST (QUOTE XX))
(SUBLEX))
(T (SETQ TEST (QUOTE EQ]
(CMP-SYMBOL TEST])
(GET-BIND
[LAMBDA (X)
(PROG (R)
(COND
((AND (SYMBOLP X)
(SETQ R (LITERAL-BINDING-OF X)))
(RETURN R))
(T (RETURN NIL])
($LITBIND
[LAMBDA (X)
(PROG (R)
(COND
((AND (SYMBOLP X)
(SETQ R (LITERAL-BINDING-OF X)))
(RETURN R))
(T (RETURN X])
(CMP-TAB
[LAMBDA NIL
(PROG (R)
(SUBLEX)
(SETQ R (SUBLEX))
(SETQ R ($LITBIND R))
(NEW-SUBNUM R])
(CMP-ANY
[LAMBDA NIL (* edited: "16-Feb-84 11:42")
(PROG (A Z)
(SUBLEX)
(SETQ Z NIL)
LA (COND
((END-OF-CE)
(%%ERROR "MISSING >>" A)))
(SETQ A (SUBLEX))
(COND
((NOT (EQ (QUOTE >>)
A))
(SETQ Z (CONS A Z))
(GO LA)))
(LINK-NEW-NODE (LIST (QUOTE &ANY)
NIL
(CURRENT-FIELD)
Z])
(CMP-ATOMIC-OR-ANY
[LAMBDA NIL
(COND
((EQ (PEEK-SUBLEX)
(QUOTE <<))
(CMP-ANY))
(T (CMP-ATOMIC])
(CMP-ELEMENT
[LAMBDA NIL (* edited: "16-Feb-84 11:40")
(AND (EQ (PEEK-SUBLEX)
(QUOTE ↑))
(CMP-TAB))
(COND
((EQ (PEEK-SUBLEX)
(QUOTE {))
(CMP-PRODUCT))
(T (CMP-ATOMIC-OR-ANY])
(CMP-CE
(LAMBDA NIL (* JonL "23-Apr-84 19:22")
(PROG (Z)
(NEW-SUBNUM 0)
(SETQ *CUR-VARS* NIL)
(SETQ Z (LEX))
(AND (ATOM Z)
(%%ERROR "ATOMIC CONDITIONS ARE NOT ALLOWED" Z))
(PREPARE-SUBLEX Z)
LA (AND (END-OF-CE)
(RETURN NIL))
(INCR-SUBNUM)
(CMP-ELEMENT)
(GO LA))))
(INCR-SUBNUM
[LAMBDA NIL
(SETQ *SUBNUM* (IPLUS 1 *SUBNUM*])
(NEW-SUBNUM
(LAMBDA (K) (* JonL "15-Feb-84 14:15")
(OR (NUMBERP K)
(%%ERROR "TAB MUST BE A NUMBER" K))
(SETQ *SUBNUM* (FIX K))))
(CMP-CE+CEVAR
[LAMBDA NIL (* edited: "16-Feb-84 11:40")
(PROG (Z)
(LEX)
(COND
((ATOM (PEEK-LEX))
(CMP-CEVAR)
(CMP-CE))
(T (CMP-CE)
(CMP-CEVAR)))
(SETQ Z (LEX))
(OR (EQ Z (QUOTE /))
(%%ERROR "MISSING }" Z])
(CMP-POSCE
[LAMBDA NIL (* edited: "16-Feb-84 11:38")
(SETQ *CE-COUNT* (IPLUS 1 *CE-COUNT*))
(COND
((EQ (PEEK-LEX)
(QUOTE {))
(CMP-CE+CEVAR))
(T (CMP-CE])
(CMP-NEGCE
[LAMBDA NIL
(LEX)
(CMP-CE])
(CMP-PRIN
[LAMBDA NIL (* edited: "16-Feb-84 11:35")
(PROG NIL
(SETQ *LAST-NODE* *FIRST-NODE*)
(COND
((NULL *LAST-BRANCH*)
(CMP-POSCE)
(CMP-NOBETA))
((EQ (PEEK-LEX)
(QUOTE -))
(CMP-NEGCE)
(CMP-NOT))
(T (CMP-POSCE)
(CMP-AND])
(KILL-NODE
[LAMBDA (NODE) (* edited: "16-Feb-84 11:34")
(PROG NIL
TOP (AND (ATOM NODE)
(RETURN NIL))
(RPLACA NODE (QUOTE &OLD))
(SETQ NODE (CDR NODE))
(GO TOP])
(EXCISE-P
[LAMBDA (NAME) (* edited: "16-Feb-84 11:34")
(COND
((AND (SYMBOLP NAME)
(GET NAME (QUOTE TOPNODE)))
(PRINT (LIST NAME (QUOTE IS)
(QUOTE EXCISED)))
(SETQ *PCOUNT* (1- *PCOUNT*))
(REMOVE-FROM-CONFLICT-SET NAME)
(KILL-NODE (GET NAME (QUOTE TOPNODE)))
(REMPROP NAME (QUOTE PRODUCTION))
(REMPROP NAME (QUOTE BACKPOINTERS))
(REMPROP NAME (QUOTE TOPNODE])
(RHS-PART
[LAMBDA (PNODE)
(CADDR (CDDDR PNODE])
(CE-VAR-PART
[LAMBDA (PNODE)
(CADR (CDDDR PNODE])
(VAR-PART
[LAMBDA (PNODE)
(CAR (CDDDR PNODE])
(RATING-PART
[LAMBDA (PNODE)
(CADR PNODE])
(CMP-P
(LAMBDA (NAME MATRIX) (* JonL "23-Apr-84 19:44")
(PROG (M BAKPTRS)
(COND
((OR (NULL NAME)
(DTPR NAME))
(%%ERROR (QUOTE (ILLEGAL PRODUCTION NAME))
NAME))
((EQUAL (GET NAME (QUOTE PRODUCTION))
MATRIX)
(RETURN NIL)))
(PREPARE-LEX MATRIX)
(EXCISE-P NAME)
(SETQ BAKPTRS NIL)
(SETQ *PCOUNT* (IPLUS 1 *PCOUNT*))
(SETQ *FEATURE-COUNT* 0)
(SETQ *CE-COUNT* 0)
(SETQ *VARS* NIL)
(SETQ *CE-VARS* NIL)
(SETQ *RHS-BOUND-VARS* NIL)
(SETQ *RHS-BOUND-CE-VARS* NIL)
(SETQ *LAST-BRANCH* NIL)
(SETQ M (REST-OF-P))
L1 (AND (END-OF-P)
(%%ERROR "NO '-->' IN PRODUCTION" M))
(CMP-PRIN)
(SETQ BAKPTRS (CONS *LAST-BRANCH* BAKPTRS))
(OR (EQ (QUOTE -->)
(PEEK-LEX))
(GO L1))
(LEX)
(CHECK-RHS (REST-OF-P))
(LINK-NEW-NODE (LIST (QUOTE &P)
*FEATURE-COUNT* NAME (ENCODE-DOPE)
(ENCODE-CE-DOPE)
(CONS (QUOTE PROGN)
(REST-OF-P))))
(PUTPROP NAME (QUOTE BACKPOINTERS)
(CDR (NREVERSE BAKPTRS)))
(PUTPROP NAME (QUOTE PRODUCTION)
MATRIX)
(PUTPROP NAME (QUOTE TOPNODE)
*LAST-NODE*))))
(MAKE-BOTTOM-NODE
[LAMBDA NIL
(SETQ *FIRST-NODE* (LIST (QUOTE &BUS)
NIL])
(PREPARE-SUBLEX
[LAMBDA (CE)
(SETQ *CURCOND* CE])
(REST-OF-CE
[LAMBDA NIL *CURCOND*])
(END-OF-CE
[LAMBDA NIL
(ATOM *CURCOND*])
(SUBLEX
[LAMBDA NIL
(PROG2 NIL (CAR *CURCOND*)
(SETQ *CURCOND*(CDR *CURCOND*])
(PEEK-SUBLEX
[LAMBDA NIL
(CAR *CURCOND*])
(PREPARE-LEX
[LAMBDA (PROD)
(SETQ *MATRIX* PROD])
(REST-OF-P
[LAMBDA NIL *MATRIX*])
(END-OF-P
[LAMBDA NIL
(ATOM *MATRIX*])
(LEX
[LAMBDA NIL
(PROG2 NIL (CAR *MATRIX*)
(SETQ *MATRIX*(CDR *MATRIX*])
(PEEK-LEX
[LAMBDA NIL
(CAR *MATRIX*])
(COMPILE-PRODUCTION
(LAMBDA (NAME MATRIX) (* JonL "15-Feb-84 11:59")
(PROG (ERM)
(SETQ *P-NAME* NAME)
(*CATCH (QUOTE !ERROR!)
(CMP-P NAME MATRIX))
(SETQ *P-NAME* NIL))))
(P
[NLAMBDA Z (* pkh: "13-Feb-84 11:14")
(FINISH-LITERALIZE)
(PRIN1 (QUOTE *))
(DRAIN)
(COMPILE-PRODUCTION (CAR Z)
(CDR Z])
(ERASE-LITERAL-INFO2
[LAMBDA (ATT) (* edited: "16-Feb-84 11:31")
(REMPROP ATT (QUOTE CONFLICTS])
(ERASE-LITERAL-INFO
[LAMBDA (CLASS) (* edited: "16-Feb-84 11:31")
(MAPC (GET CLASS (QUOTE ATT-LIST))
(FUNCTION ERASE-LITERAL-INFO2))
(REMPROP CLASS (QUOTE ATT-LIST])
(MAKE-NUMS
(LAMBDA (K) (* JonL "23-Apr-84 19:12")
(PROG (NUMS)
(SETQ NUMS NIL)
L (AND (< K 2)
(RETURN NUMS))
(SETQ NUMS (CONS (NCONS K)
NUMS))
(SETQ K (1- K))
(GO L))))
(BUCKETS
[LAMBDA NIL
(AND (ATOM *BUCKETS*)
(SETQ *BUCKETS*(MAKE-NUMS *BUCKETS*)))*BUCKETS*])
(ADD-BUCKET
[LAMBDA (NAME NUM)
(PROG (BUC)
(SETQ BUC (ASSOC NUM (BUCKETS)))
[AND (NOT (MEMQ NAME BUC))
(RPLACD BUC (CONS NAME (CDR BUC]
(RETURN BUC])
(STORE-BINDING
[LAMBDA (NAME LIT) (* edited: "16-Feb-84 11:30")
(PUTPROP NAME (QUOTE OPS-BIND)
LIT)
(ADD-BUCKET NAME LIT])
(LITERAL-BINDING-OF
[LAMBDA (NAME)
(GET NAME (QUOTE OPS-BIND])
(REMOVE-DUPLICATES
[LAMBDA (LST)
(COND
((ATOM LST)
NIL)
((MEMQ (CAR LST)
(CDR LST))
(REMOVE-DUPLICATES (CDR LST)))
(T (CONS (CAR LST)
(REMOVE-DUPLICATES (CDR LST])
(CONFLICT
[LAMBDA (A B) (* edited: "16-Feb-84 11:30")
(PROG (OLD)
(SETQ OLD (GET A (QUOTE CONFLICTS)))
(AND (NOT (EQ A B))
(NOT (MEMQ B OLD))
(PUTPROP A (QUOTE CONFLICTS)
(CONS B OLD])
(MARK-CONFLICTS2
[LAMBDA (ATM LST)
(PROG (L)
(SETQ L LST)
TOP (AND (ATOM L)
(RETURN NIL))
(CONFLICT ATM (CAR L))
(SETQ L (CDR L))
(GO TOP])
(MARK-CONFLICTS
[LAMBDA (REM ALL)
(COND
((NOT (NULL REM))
(MARK-CONFLICTS2 (CAR REM)
ALL)
(MARK-CONFLICTS (CDR REM)
ALL])
(FIND-COMMON-ATOM
[LAMBDA (LA LB)
(PROG NIL
TOP (COND
((NULL LA)
(RETURN NIL))
((MEMQ (CAR LA)
LB)
(RETURN (CAR LA)))
(T (SETQ LA (CDR LA))
(GO TOP])
(DISJOINT
[LAMBDA (LA LB)
(NOT (FIND-COMMON-ATOM LA LB])
(ASSIGN-VECTORS2
(LAMBDA (ATT) (* JonL "15-Feb-84 12:04")
(PROG (BIG CONF NEW OLD NEED)
(AND (NOT (IS-VECTOR-ATTRIBUTE ATT))
(RETURN NIL))
(SETQ BIG 1)
(SETQ CONF (GET ATT (QUOTE CONFLICTS)))
TOP (COND
((NOT (ATOM CONF))
(SETQ NEW (CAR CONF))
(SETQ CONF (CDR CONF))
(COND
((IS-VECTOR-ATTRIBUTE NEW)
(WARN "CLASS HAS TWO VECTOR ATTRIBUTES" (LIST ATT NEW)))
(T (SETQ BIG (MAX (LITERAL-BINDING-OF NEW)
BIG))))
(GO TOP)))
(SETQ NEED (1+ BIG))
(SETQ OLD (LITERAL-BINDING-OF ATT))
(COND
(OLD (NOTE-USER-VECTOR-ASSIGNS ATT OLD NEED))
(T (STORE-BINDING ATT NEED)))
(RETURN NIL))))
(ASSIGN-VECTORS
[LAMBDA (CLASS) (* edited: "16-Feb-84 11:29")
(MAPC (GET CLASS (QUOTE ATT-LIST))
(FUNCTION ASSIGN-VECTORS2])
(ASSIGN-SCALARS2
[LAMBDA (ATT) (* JonL "15-Feb-84 12:03")
(PROG (TLIST NUM BUCKET CONF)
(AND (LITERAL-BINDING-OF ATT)
(RETURN NIL))
(AND (IS-VECTOR-ATTRIBUTE ATT)
(RETURN NIL))
(SETQ TLIST (BUCKETS))
(SETQ CONF (GET ATT (QUOTE CONFLICTS)))
TOP (COND
((ATOM TLIST)
(WARN "COULD NOT GENERATE A BINDING" ATT)
(STORE-BINDING ATT -1)
(RETURN NIL)))
(SETQ NUM (CAAR TLIST))
(SETQ BUCKET (CDAR TLIST))
(SETQ TLIST (CDR TLIST))
(COND
((DISJOINT BUCKET CONF)
(STORE-BINDING ATT NUM))
(T (GO TOP])
(ASSIGN-SCALARS
[LAMBDA (CLASS) (* edited: "16-Feb-84 11:28")
(MAPC (GET CLASS (QUOTE ATT-LIST))
(FUNCTION ASSIGN-SCALARS2])
(NOTE-USER-VECTOR-ASSIGNS
(LAMBDA (ATT GIVEN NEEDED) (* JonL "23-Apr-84 19:06")
(AND (> NEEDED GIVEN)
(WARN "VECTOR ATTRIBUTE ASSIGNED TOO SMALL A VALUE IN LITERAL" ATT))))
(NOTE-USER-ASSIGNS2
[LAMBDA (ATT) (* edited: "16-Feb-84 11:28")
(PROG (NUM CONF BUCK CLASH)
(SETQ NUM (LITERAL-BINDING-OF ATT))
(AND (NULL NUM)
(RETURN NIL))
(SETQ CONF (GET ATT (QUOTE CONFLICTS)))
(SETQ BUCK (STORE-BINDING ATT NUM))
(SETQ CLASH (FIND-COMMON-ATOM BUCK CONF))
(AND CLASH (WARN "ATTRIBUTES IN A CLASS ASSIGNED THE SAME NUMBER" (CONS ATT CLASH)))
(RETURN NIL])
(NOTE-USER-ASSIGNS
[LAMBDA (CLASS) (* edited: "16-Feb-84 11:27")
(MAPC (GET CLASS (QUOTE ATT-LIST))
(FUNCTION NOTE-USER-ASSIGNS2])
(PUT-PPDAT
[LAMBDA (CLASS) (* edited: "16-Feb-84 11:26")
(PROG (AL ATT PPDAT)
(SETQ PPDAT NIL)
(SETQ AL (GET CLASS (QUOTE ATT-LIST)))
TOP (COND
((NOT (ATOM AL))
(SETQ ATT (CAR AL))
(SETQ AL (CDR AL))
(SETQ PPDAT (CONS (CONS (LITERAL-BINDING-OF ATT)
ATT)
PPDAT))
(GO TOP)))
(PUTPROP CLASS (QUOTE PPDAT)
PPDAT])
(HAVE-COMPILED-PRODUCTION
[LAMBDA NIL
(NOT (ZEROP *PCOUNT*])
(FINISH-LITERALIZE
[LAMBDA NIL (* edited: "10-Feb-84 12:47")
(COND
((NOT (NULL *CLASS-LIST*))
(MAPC *CLASS-LIST* (FUNCTION NOTE-USER-ASSIGNS))
(MAPC *CLASS-LIST* (FUNCTION ASSIGN-SCALARS))
(MAPC *CLASS-LIST* (FUNCTION ASSIGN-VECTORS))
(MAPC *CLASS-LIST* (FUNCTION PUT-PPDAT))
(MAPC *CLASS-LIST* (FUNCTION ERASE-LITERAL-INFO))
(SETQ *CLASS-LIST* NIL)
(SETQ *BUCKETS* NIL])
(TEST-ATTRIBUTE-NAMES2
[LAMBDA (ATM) (* edited: "16-Feb-84 17:19")
(COND
((OR (NOT (SYMBOLP ATM))
(VARIABLEP ATM))
(WARN "CAN BIND ONLY CONSTANT ATOMS" ATM])
(TEST-ATTRIBUTE-NAMES
[LAMBDA (L) (* edited: "10-Feb-84 12:52")
(MAPC L (FUNCTION TEST-ATTRIBUTE-NAMES2])
(IS-VECTOR-ATTRIBUTE
[LAMBDA (ATT)
(GET ATT (QUOTE VECTOR-ATTRIBUTE])
(VECTOR-ATTRIBUTE2
[LAMBDA (ATT) (* edited: "16-Feb-84 11:25")
(PUTPROP ATT (QUOTE VECTOR-ATTRIBUTE)
T])
(VECTOR-ATTRIBUTE
[NLAMBDA L (* edited: "10-Feb-84 12:52")
(COND
((HAVE-COMPILED-PRODUCTION)
(WARN "VECTOR-ATTRIBUTE CALLED AFTER P" L))
(T (TEST-ATTRIBUTE-NAMES L)
(MAPC L (FUNCTION VECTOR-ATTRIBUTE2])
(LITERALIZE
[NLAMBDA L (* edited: "16-Feb-84 17:21")
(PROG (CLASS-NAME ATTS)
(SETQ CLASS-NAME (CAR L))
(COND
((HAVE-COMPILED-PRODUCTION)
(WARN "LITERALIZE CALLED AFTER P" CLASS-NAME)
(RETURN NIL))
((GET CLASS-NAME (QUOTE ATT-LIST))
(WARN "ATTEMPT TO REDEFINE CLASS" CLASS-NAME)
(RETURN NIL)))
(SETQ *CLASS-LIST* (CONS CLASS-NAME *CLASS-LIST*))
(SETQ ATTS (REMOVE-DUPLICATES (CDR L)))
(TEST-ATTRIBUTE-NAMES ATTS)
(MARK-CONFLICTS ATTS ATTS)
(PUTPROP CLASS-NAME (QUOTE ATT-LIST)
ATTS])
(LITERAL
[NLAMBDA Z (* edited: "16-Feb-84 11:22")
(PROG (ATM VAL OLD)
TOP (AND (ATOM Z)
(RETURN (QUOTE BOUND)))
(OR (EQ (CADR Z)
(QUOTE =))
(RETURN (WARN "WRONG FORMAT")))
(SETQ ATM (CAR Z))
(SETQ VAL (CADDR Z))
(SETQ Z (CDDDR Z))
(COND
((NOT (NUMBERP VAL))
(WARN "CAN BIND ONLY NUMBERS" VAL))
((OR (NOT (SYMBOLP ATM))
(VARIABLEP ATM))
(WARN "CAN BIND ONLY CONSTANT ATOMS" ATM))
((AND (SETQ OLD (LITERAL-BINDING-OF ATM))
(NOT (EQUAL OLD VAL)))
(WARN "ATTEMPT TO BIND ATTRIBUTE" ATM))
(T (PUTPROP ATM (QUOTE OPS-BIND) VAL)))
(GO TOP])
(TOP-LEVELS-EQ
[LAMBDA (LA LB)
(PROG NIL
LX (COND
((EQ LA LB)
(RETURN T))
((NULL LA)
(RETURN NIL))
((NULL LB)
(RETURN NIL))
((NOT (EQ (CAR LA)
(CAR LB)))
(RETURN NIL)))
(SETQ LA (CDR LA))
(SETQ LB (CDR LB))
(GO LX])
(ROUND
[LAMBDA (X)
(FIX (PLUS .5 X])
(WARN
(LAMBDA (WHAT WHERE) (* JonL "15-Feb-84 13:07")
(PROG NIL
(TERPRI)
(PRIN1 (QUOTE ?))
(AND *P-NAME* (PRIN1 *P-NAME*))
(PRIN1 "..")
(PRIN1 WHERE)
(PRIN1 WHAT)
(RETURN WHERE))))
(I-G-V
(LAMBDA NIL (* JonL "23-Apr-84 19:10")
(PROG (X)
(SETQ CLISPCHARS (LDIFFERENCE CLISPCHARS (QUOTE (↑ - + < > *))))
(SETSYNTAX (QUOTE ↑)
(QUOTE BREAK)
T)
(SETQ *BUCKETS* 64)
(SETQ *ACCEPT-FILE* NIL)
(SETQ *WRITE-FILE* NIL)
(SETQ *TRACE-FILE* NIL)
(SETQ *CLASS-LIST* NIL)
(SETQ *BRKPTS* NIL)
(SETQ *STRATEGY* (QUOTE LEX))
(SETQ *IN-RHS* NIL)
(SETQ *PTRACE* T)
(SETQ *WTRACE* NIL)
(SETQ *RECORDING* NIL)
(SETQ *REFRACTS* NIL)
(SETQ *REAL-CNT* (SETQ *VIRTUAL-CNT* 0))
(SETQ *MAX-CS* (SETQ *TOTAL-CS* 0))
(SETQ *LIMIT-TOKEN* 1000000)
(SETQ *LIMIT-CS* 1000000)
(SETQ *CRITICAL* NIL)
(SETQ *BUILD-TRACE* NIL)
(SETQ *WMPART-LIST* NIL)
(SETQ *SIZE-RESULT-ARRAY* 127)
(SETQ *RESULT-ARRAY* (*MAKHUNK 6))
(SETQ *RECORD-ARRAY* (*MAKHUNK 6))
(SETQ X 0)
LOOP(PUTVECTOR *RESULT-ARRAY* X NIL)
(SETQ X (IPLUS 1 X))
(AND (NOT (> X *SIZE-RESULT-ARRAY*))
(GO LOOP))
(MAKE-BOTTOM-NODE)
(SETQ *PCOUNT* 0)
(INITIALIZE-RECORD)
(SETQ *CYCLE-COUNT* (SETQ *ACTION-COUNT* 0))
(SETQ *TOTAL-TOKEN* (SETQ *MAX-TOKEN* (SETQ *CURRENT-TOKEN* 0)))
(SETQ *TOTAL-CS* (SETQ *MAX-CS* 0))
(SETQ *TOTAL-WM* (SETQ *MAX-WM* (SETQ *CURRENT-WM* 0)))
(SETQ *CONFLICT-SET* NIL)
(SETQ *WMPART-LIST* NIL)
(SETQ *P-NAME* NIL)
(SETQ *REMAINING-CYCLES* 1000000))))
(INTRQ
[LAMBDA (X Y)
(COND
((ATOM X)
NIL)
((MEMQ (CAR X)
Y)
(CONS (CAR X)
(INTRQ (CDR X)
Y)))
(T (INTRQ (CDR X)
Y])
(PRINTLINEC*
[LAMBDA (Y) (* pkh: "13-Feb-84 13:45")
(PRIN1 (QUOTE %|))
(PRIN1 Y])
(PRINTLINEC
[LAMBDA (X) (* edited: "10-Feb-84 12:53")
(MAPC X (FUNCTION PRINTLINEC*])
(PRINTLINE*
[LAMBDA (Y)
(PRIN1 " ")
(PRINT Y])
(GELM
(LAMBDA (X K) (* JonL "23-Apr-84 19:13")
(PROG (CE SUB)
(SETQ CE (// K 10000))
(SETQ SUB (- K (ITIMES CE 10000)))
CELOOP
(AND (== CE 0)
(GO PH2))
(SETQ X (CDR X))
(AND (== CE 1)
(GO PH2))
(SETQ X (CDR X))
(AND (== CE 2)
(GO PH2))
(SETQ X (CDR X))
(AND (== CE 3)
(GO PH2))
(SETQ X (CDR X))
(AND (== CE 4)
(GO PH2))
(SETQ CE (- CE 4))
(GO CELOOP)
PH2 (SETQ X (CAR X))
SUBLOOP
(AND (== SUB 0)
(GO FINIS))
(SETQ X (CDR X))
(AND (== SUB 1)
(GO FINIS))
(SETQ X (CDR X))
(AND (== SUB 2)
(GO FINIS))
(SETQ X (CDR X))
(AND (== SUB 3)
(GO FINIS))
(SETQ X (CDR X))
(AND (== SUB 4)
(GO FINIS))
(SETQ X (CDR X))
(AND (== SUB 5)
(GO FINIS))
(SETQ X (CDR X))
(AND (== SUB 6)
(GO FINIS))
(SETQ X (CDR X))
(AND (== SUB 7)
(GO FINIS))
(SETQ X (CDR X))
(AND (== SUB 8)
(GO FINIS))
(SETQ SUB (- SUB 8))
(GO SUBLOOP)
FINIS
(RETURN (CAR X)))))
(CE-GELM
[LAMBDA (X K)
(PROG NIL
LOOP(AND (== K 1.0)
(RETURN (CAR X)))
(SETQ K (1- K))
(SETQ X (CDR X))
(GO LOOP])
(EXIT
[NLAMBDA Z
(QUIT])
(*MAKHUNK
[LAMBDA (X) (* edited: "10-Feb-84 11:18")
(ARRAY (EXPT 2 (ADD1 X])
(DRAIN
[LAMBDA NIL NIL])
(NWRITN
[LAMBDA (X) (* edited: "10-Feb-84 10:41")
(POSITION X])
)
(DEFINEQ
(%%ERROR
(LAMBDA (WHAT WHERE) (* JonL "15-Feb-84 13:04")
(WARN WHAT WHERE)
(*THROW (QUOTE !ERROR!)
(QUOTE !ERROR!))))
(WARN
(LAMBDA (WHAT WHERE) (* JonL "15-Feb-84 13:07")
(PROG NIL
(TERPRI)
(PRIN1 (QUOTE ?))
(AND *P-NAME* (PRIN1 *P-NAME*))
(PRIN1 "..")
(PRIN1 WHERE)
(PRIN1 WHAT)
(RETURN WHERE))))
)
(DEFINEQ
(TYI
(LAMBDA (STRM EOFVAL) (* JonL "15-Feb-84 12:36")
(if (EOFP (SETQ STRM (GETSTREAM STRM (QUOTE INPUT))))
then EOFVAL
else (BIN STRM))))
)
(RPAQQ GG (*MATRIX* *FEATURE-COUNT* *PCOUNT* *VARS* *CUR-VARS* *CURCOND* *SUBNUM* *LAST-NODE*
*LAST-BRANCH* *FIRST-NODE* *SENDTOCALL* *FLAG-PART* *ALPHA-FLAG-PART* *DATA-PART*
*ALPHA-DATA-PART* *CE-VARS* *VIRTUAL-CNT* *REAL-CNT* *CURRENT-TOKEN* *C1* *C2*
*C3* *C4* *C5* *C6* *C7* *C8* *C9* *C10* *C11* *C12* *C13* *C14* *C15* *C16*
*C17* *C18* *C19* *C20* *C21* *C22* *C23* *C24* *C25* *C26* *C27* *C28* *C29*
*C30* *C31* *C32* *C33* *C34* *C35* *C36* *C37* *C38* *C39* *C40* *C41* *C42*
*C43* *C44* *C45* *C46* *C47* *C48* *C49* *C50* *C51* *C52* *C53* *C54* *C55*
*C56* *C57* *C58* *C59* *C60* *C61* *C62* *C63* *C64* *RECORD-ARRAY*
*RESULT-ARRAY* *MAX-CS* *TOTAL-CS* *LIMIT-CS* *CR-TEMP* *SIDE* *CONFLICT-SET*
*HALT-FLAG* *PHASE* *CRITICAL* *CYCLE-COUNT* *TOTAL-TOKEN* *MAX-TOKEN* *REFRACTS*
*LIMIT-TOKEN* *TOTAL-WM* *CURRENT-WM* *MAX-WM* *ACTION-COUNT* *WMPART-LIST* *WM*
*DATA-MATCHED* *P-NAME* *VARIABLE-MEMORY* *CE-VARIABLE-MEMORY* *MAX-INDEX*
*NEXT-INDEX* *SIZE-RESULT-ARRAY* *REST* *BUILD-TRACE* *LAST* *PTRACE* *WTRACE*
*IN-RHS* *RECORDING* *ACCEPT-FILE* *TRACE-FILE* *WRITE-FILE* *RECORD-INDEX*
*MAX-RECORD-INDEX* *OLD-WM* *RECORD* *FILTERS* *BREAK-FLAG* *STRATEGY*
*REMAINING-CYCLES* *WM-FILTER* *RHS-BOUND-VARS* *RHS-BOUND-CE-VARS* *PPLINE*
*CE-COUNT* *BRKPTS* *CLASS-LIST* *BUCKETS* *ACTION-TYPE*))
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS *MATRIX* *FEATURE-COUNT* *PCOUNT* *VARS* *CUR-VARS* *CURCOND* *SUBNUM*
*LAST-NODE* *LAST-BRANCH* *FIRST-NODE* *SENDTOCALL* *FLAG-PART* *ALPHA-FLAG-PART*
*DATA-PART* *ALPHA-DATA-PART* *CE-VARS* *VIRTUAL-CNT* *REAL-CNT* *CURRENT-TOKEN* *C1* *C2*
*C3* *C4* *C5* *C6* *C7* *C8* *C9* *C10* *C11* *C12* *C13* *C14* *C15* *C16* *C17* *C18*
*C19* *C20* *C21* *C22* *C23* *C24* *C25* *C26* *C27* *C28* *C29* *C30* *C31* *C32* *C33*
*C34* *C35* *C36* *C37* *C38* *C39* *C40* *C41* *C42* *C43* *C44* *C45* *C46* *C47* *C48*
*C49* *C50* *C51* *C52* *C53* *C54* *C55* *C56* *C57* *C58* *C59* *C60* *C61* *C62* *C63*
*C64* *RECORD-ARRAY* *RESULT-ARRAY* *MAX-CS* *TOTAL-CS* *LIMIT-CS* *CR-TEMP* *SIDE*
*CONFLICT-SET* *HALT-FLAG* *PHASE* *CRITICAL* *CYCLE-COUNT* *TOTAL-TOKEN* *MAX-TOKEN*
*REFRACTS* *LIMIT-TOKEN* *TOTAL-WM* *CURRENT-WM* *MAX-WM* *ACTION-COUNT* *WMPART-LIST* *WM*
*DATA-MATCHED* *P-NAME* *VARIABLE-MEMORY* *CE-VARIABLE-MEMORY* *MAX-INDEX* *NEXT-INDEX*
*SIZE-RESULT-ARRAY* *REST* *BUILD-TRACE* *LAST* *PTRACE* *WTRACE* *IN-RHS* *RECORDING*
*ACCEPT-FILE* *TRACE-FILE* *WRITE-FILE* *RECORD-INDEX* *MAX-RECORD-INDEX* *OLD-WM* *RECORD*
*FILTERS* *BREAK-FLAG* *STRATEGY* *REMAINING-CYCLES* *WM-FILTER* *RHS-BOUND-VARS*
*RHS-BOUND-CE-VARS* *PPLINE* *CE-COUNT* *BRKPTS* *CLASS-LIST* *BUCKETS* *ACTION-TYPE*)
)
(DECLARE: EVAL@COMPILE
(PUTPROPS COMMENT MACRO (= . *))
(PUTPROPS + MACRO ((X . Y)
(IPLUS X . Y)))
(PUTPROPS - MACRO ((X . Y)
(IDIFFERENCE X (IPLUS . Y))))
(PUTPROPS // MACRO ((X Y)
(IQUOTIENT X Y)))
(PUTPROPS 1+ MACRO (= . ADD1))
(PUTPROPS 1- MACRO (= . SUB1))
(PUTPROPS < MACRO ((X Y) (ILESSP X Y)))
(PUTPROPS > MACRO ((X Y)
(IGREATERP X Y)))
(PUTPROPS == MACRO (= . EQ))
(PUTPROPS CXR MACRO (X
(LIST (QUOTE ELT)
(CADR X)
(CAR X))))
(PUTPROPS FAST-SYMEVAL MACRO (X
(LIST (QUOTE EVAL)
(CAR X))))
(PUTPROPS FLATC MACRO (X
(LIST (QUOTE LENGTH)
(LIST (QUOTE UNPACK)
(CAR X)))))
(PUTPROPS GETVECTOR MACRO (X
(LIST (QUOTE ELT)
(CAR X)
(BQUOTE (ADD1 , (CADR X))))))
(PUTPROPS NCONS MACRO (X
(LIST (QUOTE LIST)
(CAR X))))
(PUTPROPS PUTVECTOR MACRO (X
(LIST (QUOTE SETA)
(CAR X)
(BQUOTE (ADD1 , (CADR X)))
(CADDR X))))
)
(CLDISABLE (QUOTE MATCH))
(CLDISABLE (QUOTE *))
(CLDISABLE (QUOTE ↑))
(CLDISABLE (QUOTE -))
(CLDISABLE (QUOTE +))
(CLDISABLE (QUOTE <))
(CLDISABLE (QUOTE >))
(CLDISABLE (QUOTE =))
(RPAQQ DWIMIFYCOMPFLG NIL)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA EXIT LITERAL LITERALIZE VECTOR-ATTRIBUTE P WM MAKE MODIFY BIND CBIND REMOVEWM CALL
WRITE BUILD CLOSEFILE DEFAULT ACCEPT ACCEPTLINE SUBSTR COMPUTE ARITH LITVAL
RJUST CRLF TABTO PPWM PM MATCHES EXCISE RUN STRATEGY CS WATCH EXTERNAL PBREAK
MYDOLOOP)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PRETTYCOMPRINT OPS5S1COMS)
(RPAQQ OPS5S1COMS ((FNS BROKEN MEMQ MYDOLOOP REMATM PBREAK2 SIMPLEOPSTEST SYMBOLP GET GETCHAR PBREAK
EXTERNALP EXTERNAL3 EXTERNAL2 EXTERNAL WATCH CS STRATEGY RUN EXCISE
TOP-LEVEL-REMOVE CHECK-LIMITS PM-SIZE PRINT-TIMES ACCUM-STATS DO-CONTINUE
MAIN PROCESS-CHANGES CE-BOUND? NNREV NOTE-CE-VARIABLE NREVERSE NULLA BOUND?
NOTE-VARIABLE CHECK-TAB-INDEX CHECK-PRINT-CONTROL CHECK-SUBSTR-INDEX
CHECK-LAST-SUBSTR-INDEX CHECK-TERM CHECK-ARITHMETIC CHECK-COMPUTE
CHECK-SUBSTR CHECK-0-ARGS CHECK-RJUST CHECK-TABTO CHECK-GENATOM CHECK-CRLF
CHECK-ACCEPTLINE CHECK-ACCEPT CHECK-LITVAL CHECK-RHS-FUNCTION
CHECK-RHS-ATOMIC CHECK-RHS-VALUE CHECK-RHS-CE-VAR CHECK-CHANGE& CHECK-BIND
CHECK-CBIND CHECK-HALT CHECK-CALL CHECK-WRITE CHECK-MODIFY CHECK-DEFAULT
CHECK-CLOSEFILE CHECK-OPENFILE CHECK-MAKE CHECK-REMOVE CHECK-BUILD-COLLECT
CHECK-BUILD CHECK-ACTION CHECK-RHS FIND-RIGHT-MEM FIND-LEFT-MEM WRITE-ELMS2
WRITE-ELMS MATCHES3 MATCHES2 MATCHES BACK-PRINT STILL-PRESENT UNDO-RECORD
BACK GETVECTOR PUTVECTOR REFRACTED RECORD-REFRACT RECORD-CHANGE END-RECORD
BEGIN-RECORD INITIALIZE-RECORD RECORD-INDEX-PLUS GETUPTO GETVAL PPONLYVAL
PPATTVAL PPLINE2 PPLINE PPRULE PM PPVAL PPELM IDENT FILTER PPWM2 PPWM TABTO
CRLF RJUST LITVAL LOADOPS5 GENATOM ARI-UNIT ARI ARITH COMPUTE SUBSTR
ACCEPTLINE SPAN-CHARS FLAT-VALUE CHECK-FOR-EOF ACCEPT DEFAULT CLOSEFILE2
CLOSEFILE $OFILE $IFILE BUILD HALT DO-TABTO DO-RJUST DEFAULT-WRITE-FILE WRITE
CALL REMOVEWM CBIND BIND MODIFY MAKE $PARAMETER $PARAMETERCOUNT $ASSERT
USE-RESULT-ARRAY $VALUE $TAB RHS-TAB $RESET EVAL-FUNCTION EVAL-ARGS $CHANGE
UNFLAT* UNFLAT BUILD-COLLECT GET-NUM-CE GET-CE-VAR-BIND ASSQ $VARBIND
MAKE-VAR-BIND MAKE-CE-VAR-BIND INIT-CE-VAR-MEM INIT-VAR-MEM TIME-TAG-PRINT
EVAL-RHS TRACE-FILE REFRESH-ADD REFRESH-DEL REFRESH-COLLECT REFRESH
CREATION-TIME WM-HASH GET-WM2 GET-WM WM MAPWM REMOVE-FROM-WM ADD-TO-WM
CONCAT-AMOS CONFLICT-SET CONFLICT-SET-COMPARE INSTANTIATION ORDER-PART
PNAME-INSTANTIATION REMOVE-FROM-CONFLICT-SET BEST-OF* BEST-OF
CONFLICT-RESOLUTION DSORT ORDER-TAGS INSERTCS REMOVECS REMOVE-OLD-NO-NUM
REMOVE-OLD-NUM REMOVE-OLD REAL-ADD-TOKEN ADD-TOKEN NOT-RIGHT NOT-LEFT &NOT
&OLD &P TXXB TLEB TGEB TGTB TLTB TNEB TEQB AND-RIGHT AND-LEFT &AND &MEM &TWO
TLES TGES TGTS TLTS TXXS TNES TEQS TLEN TGEN TGTN TLTN TXXN TNEN TEQN TXXA
TNEA TEQA &ANY &BUS SENDTO EVAL-NODELIST MATCH BETA-EQUIV EQUIV
FIND-EQUIV-BETA-NODE FIND-EQUIV-NODE LEFT-OUTS RIGHT-OUTS ATTACH-LEFT
ATTACH-RIGHT LINK-BOTH LINK-LEFT LINK-NEW-BETA-NODE LINK-TO-BRANCH
LINK-NEW-NODE ENCODE-CE-DOPE ENCODE-DOPE MEMORY-PART PROTOMEM BUILD-BETA
FUDGE* FUDGE PROMOTE-VAR ENCODE-SINGLETON ENCODE-PAIR ADD-TEST CMP-BETA
CMP-AND CMP-NOBETA CMP-NOT CMP-CEVAR CMP-NEW-EQ-VAR CMP-OLD-EQ-VAR
CMP-NEW-VAR CMP-VAR CE-VAR-DOPE VAR-DOPE FIELD-NAME CURRENT-FIELD CMP-NUMBER
CMP-CONSTANT CMP-SYMBOL VARIABLEP CMP-PRODUCT CMP-ATOMIC GET-BIND $LITBIND
CMP-TAB CMP-ANY CMP-ATOMIC-OR-ANY CMP-ELEMENT CMP-CE INCR-SUBNUM NEW-SUBNUM
CMP-CE+CEVAR CMP-POSCE CMP-NEGCE CMP-PRIN KILL-NODE EXCISE-P RHS-PART
CE-VAR-PART VAR-PART RATING-PART CMP-P MAKE-BOTTOM-NODE PREPARE-SUBLEX
REST-OF-CE END-OF-CE SUBLEX PEEK-SUBLEX PREPARE-LEX REST-OF-P END-OF-P LEX
PEEK-LEX COMPILE-PRODUCTION P ERASE-LITERAL-INFO2 ERASE-LITERAL-INFO
MAKE-NUMS BUCKETS ADD-BUCKET STORE-BINDING LITERAL-BINDING-OF
REMOVE-DUPLICATES CONFLICT MARK-CONFLICTS2 MARK-CONFLICTS FIND-COMMON-ATOM
DISJOINT ASSIGN-VECTORS2 ASSIGN-VECTORS ASSIGN-SCALARS2 ASSIGN-SCALARS
NOTE-USER-VECTOR-ASSIGNS NOTE-USER-ASSIGNS2 NOTE-USER-ASSIGNS PUT-PPDAT
HAVE-COMPILED-PRODUCTION FINISH-LITERALIZE TEST-ATTRIBUTE-NAMES2
TEST-ATTRIBUTE-NAMES IS-VECTOR-ATTRIBUTE VECTOR-ATTRIBUTE2 VECTOR-ATTRIBUTE
LITERALIZE LITERAL TOP-LEVELS-EQ ROUND WARN I-G-V INTRQ PRINTLINEC*
PRINTLINEC PRINTLINE* GELM CE-GELM EXIT *MAKHUNK DRAIN NWRITN)
(FNS %%ERROR WARN)
(FNS TYI)
(VARS GG)
(DECLARE: EVAL@COMPILE DONTCOPY (GLOBALVARS * GG)
(MACROS COMMENT + - // 1+ 1- < > == CXR FAST-SYMEVAL FLATC GETVECTOR NCONS
PUTVECTOR)
(P (CLDISABLE (QUOTE MATCH))
(CLDISABLE (QUOTE *))
(CLDISABLE (QUOTE ↑))
(CLDISABLE (QUOTE -))
(CLDISABLE (QUOTE +))
(CLDISABLE (QUOTE <))
(CLDISABLE (QUOTE >))
(CLDISABLE (QUOTE =)))
(VARS (DWIMIFYCOMPFLG)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA BIND CBIND WRITE ACCEPT ACCEPTLINE SUBSTR LITVAL RJUST TABTO PPWM
RUN EXIT LITERAL LITERALIZE VECTOR-ATTRIBUTE P WM MAKE MODIFY
REMOVEWM CALL BUILD CLOSEFILE DEFAULT COMPUTE ARITH CRLF PM MATCHES
EXCISE STRATEGY CS WATCH EXTERNAL PBREAK MYDOLOOP)
(NLAML)
(LAMA)))))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA BIND CBIND WRITE ACCEPT ACCEPTLINE SUBSTR LITVAL RJUST TABTO PPWM RUN EXIT LITERAL
LITERALIZE VECTOR-ATTRIBUTE P WM MAKE MODIFY REMOVEWM CALL BUILD CLOSEFILE
DEFAULT COMPUTE ARITH CRLF PM MATCHES EXCISE STRATEGY CS WATCH EXTERNAL PBREAK
MYDOLOOP)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS OPS5S1 COPYRIGHT ("AMOS BARZILAY" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (5801 121646 (BROKEN 5811 . 5865) (MEMQ 5867 . 6059) (MYDOLOOP 6061 . 6640) (REMATM 6642
. 6829) (PBREAK2 6831 . 7139) (SIMPLEOPSTEST 7141 . 8042) (SYMBOLP 8044 . 8166) (GET 8168 . 8290) (
GETCHAR 8292 . 8416) (PBREAK 8418 . 8616) (EXTERNALP 8618 . 8857) (EXTERNAL3 8859 . 9099) (EXTERNAL2
9101 . 9244) (EXTERNAL 9246 . 9405) (WATCH 9407 . 9988) (CS 9990 . 10163) (STRATEGY 10165 . 10469) (
RUN 10471 . 10820) (EXCISE 10822 . 10961) (TOP-LEVEL-REMOVE 10963 . 11213) (CHECK-LIMITS 11215 . 11739
) (PM-SIZE 11741 . 11927) (PRINT-TIMES 11929 . 13067) (ACCUM-STATS 13069 . 13499) (DO-CONTINUE 13501
. 13768) (MAIN 13770 . 14847) (PROCESS-CHANGES 14849 . 15300) (CE-BOUND? 15302 . 15404) (NNREV 15406
. 15602) (NOTE-CE-VARIABLE 15604 . 15708) (NREVERSE 15710 . 15873) (NULLA 15875 . 16103) (BOUND?
16105 . 16189) (NOTE-VARIABLE 16191 . 16280) (CHECK-TAB-INDEX 16282 . 16681) (CHECK-PRINT-CONTROL
16683 . 17000) (CHECK-SUBSTR-INDEX 17002 . 17412) (CHECK-LAST-SUBSTR-INDEX 17414 . 17593) (CHECK-TERM
17595 . 17793) (CHECK-ARITHMETIC 17795 . 18211) (CHECK-COMPUTE 18213 . 18280) (CHECK-SUBSTR 18282 .
18584) (CHECK-0-ARGS 18586 . 18772) (CHECK-RJUST 18774 . 18994) (CHECK-TABTO 18996 . 19216) (
CHECK-GENATOM 19218 . 19276) (CHECK-CRLF 19278 . 19333) (CHECK-ACCEPTLINE 19335 . 19501) (CHECK-ACCEPT
19503 . 19735) (CHECK-LITVAL 19737 . 19955) (CHECK-RHS-FUNCTION 19957 . 20794) (CHECK-RHS-ATOMIC
20796 . 20916) (CHECK-RHS-VALUE 20918 . 21123) (CHECK-RHS-CE-VAR 21125 . 21473) (CHECK-CHANGE& 21475
. 22092) (CHECK-BIND 22094 . 22472) (CHECK-CBIND 22474 . 22824) (CHECK-HALT 22826 . 22919) (
CHECK-CALL 22921 . 23455) (CHECK-WRITE 23457 . 23577) (CHECK-MODIFY 23579 . 23799) (CHECK-DEFAULT
23801 . 23923) (CHECK-CLOSEFILE 23925 . 24049) (CHECK-OPENFILE 24051 . 24174) (CHECK-MAKE 24176 .
24295) (CHECK-REMOVE 24297 . 24517) (CHECK-BUILD-COLLECT 24519 . 25011) (CHECK-BUILD 25013 . 25139) (
CHECK-ACTION 25141 . 26141) (CHECK-RHS 26143 . 26291) (FIND-RIGHT-MEM 26293 . 26365) (FIND-LEFT-MEM
26367 . 26591) (WRITE-ELMS2 26593 . 26673) (WRITE-ELMS 26675 . 26877) (MATCHES3 26879 . 27361) (
MATCHES2 27363 . 27601) (MATCHES 27603 . 27765) (BACK-PRINT 27767 . 27902) (STILL-PRESENT 27904 .
28111) (UNDO-RECORD 28113 . 29406) (BACK 29408 . 29871) (GETVECTOR 29873 . 30003) (PUTVECTOR 30005 .
30142) (REFRACTED 30144 . 30326) (RECORD-REFRACT 30328 . 30542) (RECORD-CHANGE 30544 . 30678) (
END-RECORD 30680 . 31026) (BEGIN-RECORD 31028 . 31149) (INITIALIZE-RECORD 31151 . 31396) (
RECORD-INDEX-PLUS 31398 . 31714) (GETUPTO 31716 . 31987) (GETVAL 31989 . 32605) (PPONLYVAL 32607 .
33132) (PPATTVAL 33134 . 33629) (PPLINE2 33631 . 34037) (PPLINE 34039 . 34332) (PPRULE 34334 . 35559)
(PM 35561 . 35717) (PPVAL 35719 . 35966) (PPELM 35968 . 36976) (IDENT 36978 . 37211) (FILTER 37213 .
37538) (PPWM2 37540 . 37662) (PPWM 37664 . 38614) (TABTO 38616 . 39127) (CRLF 39129 . 39339) (RJUST
39341 . 39862) (LITVAL 39864 . 40443) (LOADOPS5 40445 . 40809) (GENATOM 40811 . 40863) (ARI-UNIT 40865
. 41220) (ARI 41222 . 41993) (ARITH 41995 . 42047) (COMPUTE 42049 . 42103) (SUBSTR 42105 . 43598) (
ACCEPTLINE 43600 . 45123) (SPAN-CHARS 45125 . 45400) (FLAT-VALUE 45402 . 45595) (CHECK-FOR-EOF 45597
. 45781) (ACCEPT 45783 . 46788) (DEFAULT 46790 . 48041) (CLOSEFILE2 48043 . 48420) (CLOSEFILE 48422
. 48629) ($OFILE 48631 . 48737) ($IFILE 48739 . 48844) (BUILD 48846 . 49313) (HALT 49315 . 49540) (
DO-TABTO 49542 . 49910) (DO-RJUST 49912 . 50700) (DEFAULT-WRITE-FILE 50702 . 50999) (WRITE 51001 .
52310) (CALL 52312 . 52536) (REMOVEWM 52538 . 52960) (CBIND 52962 . 53450) (BIND 53452 . 54111) (
MODIFY 54113 . 54733) (MAKE 54735 . 54847) ($PARAMETER 54849 . 55163) ($PARAMETERCOUNT 55165 . 55213)
($ASSERT 55215 . 55313) (USE-RESULT-ARRAY 55315 . 55657) ($VALUE 55659 . 56040) ($TAB 56042 . 56768) (
RHS-TAB 56770 . 56828) ($RESET 56830 . 56986) (EVAL-FUNCTION 56988 . 57219) (EVAL-ARGS 57221 . 57725)
($CHANGE 57727 . 57949) (UNFLAT* 57951 . 58365) (UNFLAT 58367 . 58431) (BUILD-COLLECT 58433 . 58890) (
GET-NUM-CE 58892 . 59319) (GET-CE-VAR-BIND 59321 . 59550) (ASSQ 59552 . 59671) ($VARBIND 59673 . 59876
) (MAKE-VAR-BIND 59878 . 59985) (MAKE-CE-VAR-BIND 59987 . 60103) (INIT-CE-VAR-MEM 60105 . 60503) (
INIT-VAR-MEM 60505 . 60888) (TIME-TAG-PRINT 60890 . 61152) (EVAL-RHS 61154 . 61924) (TRACE-FILE 61926
. 62215) (REFRESH-ADD 62217 . 62291) (REFRESH-DEL 62293 . 62356) (REFRESH-COLLECT 62358 . 62429) (
REFRESH 62431 . 62760) (CREATION-TIME 62762 . 62866) (WM-HASH 62868 . 63136) (GET-WM2 63138 . 63277) (
GET-WM 63279 . 63420) (WM 63422 . 63640) (MAPWM 63642 . 64004) (REMOVE-FROM-WM 64006 . 64827) (
ADD-TO-WM 64829 . 65870) (CONCAT-AMOS 65872 . 66011) (CONFLICT-SET 66013 . 66879) (
CONFLICT-SET-COMPARE 66881 . 67909) (INSTANTIATION 67911 . 68005) (ORDER-PART 68007 . 68073) (
PNAME-INSTANTIATION 68075 . 68150) (REMOVE-FROM-CONFLICT-SET 68152 . 68588) (BEST-OF* 68590 . 68788) (
BEST-OF 68790 . 68864) (CONFLICT-RESOLUTION 68866 . 69374) (DSORT 69376 . 69988) (ORDER-TAGS 69990 .
70373) (INSERTCS 70375 . 70732) (REMOVECS 70734 . 71244) (REMOVE-OLD-NO-NUM 71246 . 71846) (
REMOVE-OLD-NUM 71848 . 72462) (REMOVE-OLD 72464 . 72599) (REAL-ADD-TOKEN 72601 . 72799) (ADD-TOKEN
72801 . 73230) (NOT-RIGHT 73232 . 74579) (NOT-LEFT 74581 . 75574) (&NOT 75576 . 75917) (&OLD 75919 .
75960) (&P 75962 . 76323) (TXXB 76325 . 76493) (TLEB 76495 . 76657) (TGEB 76659 . 76821) (TGTB 76823
. 76979) (TLTB 76981 . 77137) (TNEB 77139 . 77387) (TEQB 77389 . 77639) (AND-RIGHT 77641 . 78632) (
AND-LEFT 78634 . 79622) (&AND 79624 . 80040) (&MEM 80042 . 80490) (&TWO 80492 . 80892) (TLES 80894 .
81134) (TGES 81136 . 81376) (TGTS 81378 . 81612) (TLTS 81614 . 81848) (TXXS 81850 . 82154) (TNES 82156
. 82517) (TEQS 82519 . 82870) (TLEN 82872 . 83070) (TGEN 83072 . 83270) (TGTN 83272 . 83464) (TLTN
83466 . 83658) (TXXN 83660 . 83822) (TNEN 83824 . 84086) (TEQN 84088 . 84336) (TXXA 84338 . 84453) (
TNEA 84455 . 84584) (TEQA 84586 . 84713) (&ANY 84715 . 85374) (&BUS 85376 . 89387) (SENDTO 89389 .
89746) (EVAL-NODELIST 89748 . 90083) (MATCH 90085 . 90192) (BETA-EQUIV 90194 . 90449) (EQUIV 90451 .
90656) (FIND-EQUIV-BETA-NODE 90658 . 90900) (FIND-EQUIV-NODE 90902 . 91134) (LEFT-OUTS 91136 . 91184)
(RIGHT-OUTS 91186 . 91236) (ATTACH-LEFT 91238 . 91327) (ATTACH-RIGHT 91329 . 91421) (LINK-BOTH 91423
. 91796) (LINK-LEFT 91798 . 92079) (LINK-NEW-BETA-NODE 92081 . 92273) (LINK-TO-BRANCH 92275 . 92416)
(LINK-NEW-NODE 92418 . 92681) (ENCODE-CE-DOPE 92683 . 92993) (ENCODE-DOPE 92995 . 93337) (MEMORY-PART
93339 . 93404) (PROTOMEM 93406 . 93449) (BUILD-BETA 93451 . 94096) (FUDGE* 94098 . 94206) (FUDGE 94208
. 94388) (PROMOTE-VAR 94390 . 94859) (ENCODE-SINGLETON 94861 . 94908) (ENCODE-PAIR 94910 . 95064) (
ADD-TEST 95066 . 95532) (CMP-BETA 95534 . 96302) (CMP-AND 96304 . 96443) (CMP-NOBETA 96445 . 96498) (
CMP-NOT 96500 . 96639) (CMP-CEVAR 96641 . 96991) (CMP-NEW-EQ-VAR 96993 . 97529) (CMP-OLD-EQ-VAR 97531
. 97802) (CMP-NEW-VAR 97804 . 97906) (CMP-VAR 97908 . 98345) (CE-VAR-DOPE 98347 . 98405) (VAR-DOPE
98407 . 98459) (FIELD-NAME 98461 . 98742) (CURRENT-FIELD 98744 . 98807) (CMP-NUMBER 98809 . 99061) (
CMP-CONSTANT 99063 . 99436) (CMP-SYMBOL 99438 . 99978) (VARIABLEP 99980 . 100155) (CMP-PRODUCT 100157
. 100648) (CMP-ATOMIC 100650 . 101442) (GET-BIND 101444 . 101606) ($LITBIND 101608 . 101768) (CMP-TAB
101770 . 101931) (CMP-ANY 101933 . 102414) (CMP-ATOMIC-OR-ANY 102416 . 102550) (CMP-ELEMENT 102552 .
102836) (CMP-CE 102838 . 103297) (INCR-SUBNUM 103299 . 103368) (NEW-SUBNUM 103370 . 103568) (
CMP-CE+CEVAR 103570 . 103947) (CMP-POSCE 103949 . 104196) (CMP-NEGCE 104198 . 104258) (CMP-PRIN 104260
. 104650) (KILL-NODE 104652 . 104914) (EXCISE-P 104916 . 105381) (RHS-PART 105383 . 105440) (
CE-VAR-PART 105442 . 105501) (VAR-PART 105503 . 105558) (RATING-PART 105560 . 105612) (CMP-P 105614 .
107025) (MAKE-BOTTOM-NODE 107027 . 107118) (PREPARE-SUBLEX 107120 . 107179) (REST-OF-CE 107181 .
107222) (END-OF-CE 107224 . 107274) (SUBLEX 107276 . 107368) (PEEK-SUBLEX 107370 . 107421) (
PREPARE-LEX 107423 . 107482) (REST-OF-P 107484 . 107523) (END-OF-P 107525 . 107573) (LEX 107575 .
107661) (PEEK-LEX 107663 . 107710) (COMPILE-PRODUCTION 107712 . 107970) (P 107972 . 108188) (
ERASE-LITERAL-INFO2 108190 . 108345) (ERASE-LITERAL-INFO 108347 . 108580) (MAKE-NUMS 108582 . 108873)
(BUCKETS 108875 . 108983) (ADD-BUCKET 108985 . 109186) (STORE-BINDING 109188 . 109378) (
LITERAL-BINDING-OF 109380 . 109456) (REMOVE-DUPLICATES 109458 . 109673) (CONFLICT 109675 . 109969) (
MARK-CONFLICTS2 109971 . 110178) (MARK-CONFLICTS 110180 . 110334) (FIND-COMMON-ATOM 110336 . 110543) (
DISJOINT 110545 . 110615) (ASSIGN-VECTORS2 110617 . 111425) (ASSIGN-VECTORS 111427 . 111615) (
ASSIGN-SCALARS2 111617 . 112340) (ASSIGN-SCALARS 112342 . 112530) (NOTE-USER-VECTOR-ASSIGNS 112532 .
112756) (NOTE-USER-ASSIGNS2 112758 . 113289) (NOTE-USER-ASSIGNS 113291 . 113485) (PUT-PPDAT 113487 .
113949) (HAVE-COMPILED-PRODUCTION 113951 . 114021) (FINISH-LITERALIZE 114023 . 114468) (
TEST-ATTRIBUTE-NAMES2 114470 . 114709) (TEST-ATTRIBUTE-NAMES 114711 . 114877) (IS-VECTOR-ATTRIBUTE
114879 . 114962) (VECTOR-ATTRIBUTE2 114964 . 115133) (VECTOR-ATTRIBUTE 115135 . 115426) (LITERALIZE
115428 . 116113) (LITERAL 116115 . 116872) (TOP-LEVELS-EQ 116874 . 117192) (ROUND 117194 . 117240) (
WARN 117242 . 117544) (I-G-V 117546 . 119252) (INTRQ 119254 . 119429) (PRINTLINEC* 119431 . 119577) (
PRINTLINEC 119579 . 119725) (PRINTLINE* 119727 . 119787) (GELM 119789 . 121141) (CE-GELM 121143 .
121311) (EXIT 121313 . 121347) (*MAKHUNK 121349 . 121486) (DRAIN 121488 . 121518) (NWRITN 121520 .
121644)) (121647 122145 (%%ERROR 121657 . 121839) (WARN 121841 . 122143)) (122146 122366 (TYI 122156
. 122364)))))
STOP