Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
00100 (PROG (SEXPR IBASE)
00200 (SETQ IBASE (ADD1 7))
00300 LOOP (SETQ SEXPR (ERRSET (READ)))
00400 (COND ((EQ SEXPR (QUOTE $EOF$)) (RETURN (QUOTE COMPILER-LOADED))))
00500 (COND ((MEMQ (CAAR SEXPR) (QUOTE (BEGINBLOCK ENDBLOCK))) (GO LOOP)))
00600 (PRINT (EVAL (CAR SEXPR)))
00700 (GO LOOP))
00800
00900 (BEGINBLOCK COMPILER)
01000
01100 (COND ((EQ (CDR (GET (QUOTE COMPILING) (QUOTE VALUE))) (QUOTE NOW))
01200 (SPECIAL LASTOUT LOCVARS SPECVARS TAGCNT P1CNT P2CNT)
01300 (SPECIAL ALLVARS RENAMELIST INPROG P1SCNT P1SCV FOUNDFREE)
01400 (SPECIAL COMPILING CODESIZE CONSTSIZE LISTING INDEV OUTDEV)
01500 (SPECIAL ARGACS REGPDL PDLDEPTH MINDEPTH)
01600 (SPECIAL LDLST PRGSPFLG PROGVARS SPLDLST CCLST RSL)
01700 (SPECIAL CTAG RSL)
01800 (SPECIAL PROGSW GOLIST VARLIST)
01900 (SPECIAL GOLIST EXIT EXITN PRSSL PROGSW VGO PVR)
02000 (SPECIAL FUNNAME FUNTYPE FUNFLAG)
02100 (SPECIAL NACS VALUEAC PDLAC ALLACS INUM0 MSGDEV GOTABAC FARGAC ARRAYAC)
02200 (SPECIAL LINCNT PAGEWIDTH PAGEHEIGHT)
02300 (SPECIAL ALLFUNS GENFUNS UNDFUNS STARTTIME)
02400 (SPECIAL P1FUN P2FUN BOOLFUN ACTFUN)
02500 (SPECIAL *SP *TB *CR *LF *VT *FF *CO *PT *LP *RP *SL *AM *AT *RO *COLON)
02600 (SPECIAL IBASE BASE *NOPOINT)
02700 (SPECIAL TRACELIST DB)
02800 (PRINTMSG (QUOTE DECLARATIONS-MADE))))
02900
00100 (BEGINBLOCK MACROS)
00200
00300 (DEFPROP DFUNC (LAMBDA (L) (LIST (Q DEFPROP)
00400 (CAADR L)
00500 (MCONS (Q LAMBDA) (CDADR L) (CDDR L))
00600 (Q EXPR)))
00700 MACRO)
00800
00900 (DEFPROP DOCDR
01000 (LAMBDA (CALL) (LIST (Q SETQ) (CADR CALL) (LIST (Q CDR) (CADR CALL))))
01100 MACRO)
01200
01300 (DEFPROP FLUSHDEF (LAMBDA (L) (CONS (Q FLUSHEXPR) (CDR L))) MACRO)
01400
01500 (DEFPROP GENFUNNAME (LAMBDA (L) (Q (MAKESYM FUNNAME (GENSYM)))) MACRO)
01600
01700 (DEFPROP GENTAG (LAMBDA (L) (Q (GENSYM))) MACRO)
01800
01900 (DEFPROP GENVAL (LAMBDA (L) (Q (GENSYM))) MACRO)
02000
02100 (DEFPROP GETPROP (LAMBDA (L) (CONS (Q GET) (CDR L))) MACRO)
02200
02300 (DEFPROP IFIF
02400 (LAMBDA (L) (LIST (Q COND) (CDR L) (LIST T (CONS (Q NOT) (CDDR L)))))
02500 MACRO)
02600
02700 (DEFPROP INCR
02800 (LAMBDA (L) (LIST (QUOTE SETQ) (CADR L) (LIST (QUOTE ADD1) (CADR L))))
02900 MACRO)
03000
03100 (DEFPROP MAPDEF
03200 (LAMBDA (L)
03300 (LIST (Q MAPCAR)
03400 (SUBST (CADR L)
03500 (Q IND)
03600 (Q (FUNCTION
03700 (LAMBDA (PAIR)
03800 (PUTPROP (CAR PAIR) (CADR PAIR) (QUOTE IND))))))
03900 (LIST (Q QUOTE) (CADDR L))))
04000 MACRO)
04100
00100 (DEFPROP MCONS
00200 (LAMBDA (L)
00300 (COND ((NULL (CDDR L)) (CADR L))
00400 (T (LIST (Q CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
00500 MACRO)
00600
00700 (DEFPROP OUTINST (LAMBDA (INST) (CONS (Q OUTSTAT) (CDR INST))) MACRO)
00800
00900 (DEFPROP OUTPSOP (LAMBDA (PSOP) (CONS (Q OUTSTAT) (CDR PSOP))) MACRO)
01000
01100 (DEFPROP OUTTAG (LAMBDA (TAG) (CONS (Q OUTSTAT) (CDR TAG))) MACRO)
01200
01300 (DEFPROP PDLINDEX (LAMBDA (L) (Q (MINUS (ADD1 PDLDEPTH)))) MACRO)
01400
01500 (DEFPROP PROPTABLE (LAMBDA (L) (CONS (Q CDR) (CDR L))) MACRO)
01600
01700 (DEFPROP PROPVAL (LAMBDA (L) (CONS (Q CAR) (CDR L))) MACRO)
01800
01900 (DEFPROP Q (LAMBDA (L) (CONS (QUOTE QUOTE) (CDR L))) MACRO)
02000
02100 (DEFPROP REPLACECAR (LAMBDA (L) (CONS (Q RPLACA) (CDR L))) MACRO)
02200
02300 (DEFPROP REPLACECDR (LAMBDA (L) (CONS (Q RPLACD) (CDR L))) MACRO)
02400
02500 (DEFPROP TAGP (LAMBDA (L) (CONS (Q ATOM) (CDR L))) MACRO)
02600
02700 (ENDBLOCK MACROS)
02800
00100 (BEGINBLOCK TOPLEVEL)
00200
00300 (DFUNC (ACTONEXPR XPR) (PROG (ACTION COMPILING)
00400 (SETQ COMPILING (QUOTE NOW))
00500 (COND ((ATOM XPR) (GO FLUSH)))
00600 (SETQ ACTION (GETGET (CAR XPR) (Q COMPEFFECT)))
00700 (SETQ ACTFUN ACTION)
00800 (COND (ACTION ((CAR ACTION) XPR) (RETURN NIL)))
00900 FLUSH(FLUSHEXPR XPR)
01000 (RETURN NIL)))
01100
01200 (DFUNC (ACTONMACRO XPR) (ACTONEXPR ((GETPROP (CAR XPR) (Q MACRO)) XPR)))
01300
01400 (DFUNC (CF) (COMPFILE (GETPROP (QUOTE TRY) (Q FILE))))
01500
01600 (DEFPROP CMP
01700 (LAMBDA (L)
01800 (PROG2 (PUTPROP (CAAR L)
01900 (MCONS (Q LAMBDA) (CDAR L) (CDR L))
02000 (Q EXPR))
02100 (EVAL (LIST (Q COMPILE) (CAAR L)))))
02200 FEXPR)
02300
02400 (DEFPROP COMFILE
02500 (LAMBDA (FILE) (PROG (CODESIZE CONSTSIZE)
02600 (PUTPROP (Q TRY) FILE (Q FILE))
02700 (SETQ CODESIZE (SETQ CONSTSIZE 0))
02800 (RETURN (COMPFILE FILE))))
02900 FEXPR)
03000
03100 (DFUNC (COMPDEF DEFIN)
03200 (PROG (ACTION)
03300 (COND ((NOT (EQUAL (LENGTH DEFIN) 4)) (DATAERR ARGNOERR-COMPDEF)))
03400 (COND ((SETQ ACTION (SEEKPROP (CADDDR DEFIN) (Q DEFACTION)))
03500 ((PROPVAL ACTION) DEFIN)
03600 (RETURN NIL)))
03700 (FLUSHDEF DEFIN)
03800 (RETURN NIL)))
03900
04000 (DFUNC (COMPFILE INFILE OUTFILE)
04100 (PROG (ALLFUNS UNDFUNS GENFUNS CODESIZE CONSTSIZE FOUNDFREE STARTTIME)
04200 (CARRET)
04300 (SETQ STARTTIME (TIME))
04400 (SETQ CODESIZE (SETQ CONSTSIZE 0))
04500 (DOFILE (FUNCTION COMPREADS) INFILE OUTFILE)
04600 (TELLTALE (CADR INFILE))
04700 (LINEF)))
04800
00100 (DFUNC (COMPFUNC FUNNAME FUNEXP FUNFLAG FUNTYPE)
00200 (PROG (LOCVARS SPECVARS P1EXP P1CNT P2CNT)
00300 (PUTPROP FUNNAME T FUNTYPE)
00400 (SETQ P1EXP (PASS1 FUNEXP))
00500 (P1SPY P1EXP)
00600 (CARRET)
00700 (PASS2 P1EXP)
00800 (CARRET)
00900 (LINEF)
01000 (COND ((NOT (EQUAL P2CNT P1CNT)) (PRINTMSG (LIST P1CNT P2CNT))
01100 (BARF COUNTSDISAGREE-COMPFUNC)))
01200 (PRINSTTY FUNNAME)
01300 (RETURN FUNNAME)))
01400
01500 (DEFPROP COMPILE
01600 (LAMBDA (NAMES)
01700 (PROG (GENFUNS UNDFUNS CODESIZE CONSTSIZE DONE PROP NAME FLAG PLIST)
01800 (SETQ CODESIZE (SETQ CONSTSIZE 0))
01900 LOOP (COND ((NULL NAMES) (RETURN (REVERSE DONE))))
02000 (SETQ NAME (CAR NAMES))
02100 (SETQ NAMES (CDR NAMES))
02200 (SETQ PLIST (CDR NAME))
02300 ILOOP(COND ((NULL PLIST) (GO LOOP)))
02400 (SETQ FLAG (CAR PLIST))
02500 (SETQ PLIST (CDR PLIST))
02600 (SETQ PROP (SEEKPROP FLAG (Q DEFACTION)))
02700 (COND ((NULL PROP) (GO ELOOP)))
02800 (SETQ DONE (CONS (CONS NAME FLAG) DONE))
02900 (CARRET)
03000 ((PROPVAL PROP) (LIST (Q DEFPROP) NAME (CAR PLIST) FLAG))
03100 (LINEF)
03200 ELOOP(SETQ PLIST (CDR PLIST))
03300 (GO ILOOP)))
03400 FEXPR)
03500
00100 (DEFPROP COMPL
00200 (LAMBDA (FILES)
00300 (PROG NIL
00400 (SETQ MSGDEV (COND (LISTING (EVAL (CONS (Q OUTPUT) (CONS (Q LST) LISTING))))))
00500 LOOP (COND ((NULL FILES)
00600 (OUTC MSGDEV NIL)
00700 (SETQ MSGDEV NIL)
00800 (OUTC NIL T)
00900 (RETURN NIL)))
01000 (COND ((OR (EQ (CAR (LAST (EXPLODE (CAR FILES)))) *COLON)
01100 (AND (NOT (ATOM (CAR FILES))) (NOT (ATOM (CDAR FILES)))))
01200 (SETQ INDEV (CAR FILES))
01300 (GO ELOOP)))
01400 (COMPFILE (LIST INDEV (CAR FILES))
01500 (LIST OUTDEV
01600 (CONS (COND ((ATOM (CAR FILES)) (CAR FILES))
01700 (T (CAAR FILES)))
01800 (Q LAP))))
01900 ELOOP(DOCDR FILES)
02000 (GO LOOP)))
02100 FEXPR)
02200
02300 (DFUNC (COMPREADS) (READLOOP (FUNCTION ACTONEXPR)))
02400
02500 (DFUNC (CT) (COMPILE TRY))
02600 (DFUNC (DEFEXPR DEFIN)
02700 (PROG (NAME EXP)
02800 (SETQ NAME (CADR DEFIN))
02900 (SETQ EXP (CADDR DEFIN))
03000 (COND ((ATOM EXP) (FLUSHDEF DEFIN))
03100 ((NOT (EQ (CAR EXP) (Q LAMBDA))) (DATAERR NONLAMBDA-DEFEXPR))
03200 ((AND (CADR EXP) (ATOM (CADR EXP)))
03300 (COMPFUNC NAME EXP (Q LSUBR) (Q *LSUBR)))
03400 (T (COMPFUNC NAME EXP (Q SUBR) (Q *SUBR))))))
03500
03600 (DFUNC (DEFFEXPR DEF) (COMPFUNC (CADR DEF) (CADDR DEF) (Q FSUBR) (Q *FSUBR)))
03700
00100 (DFUNC (DO*EXPR DEF) (PUTPROP (CADR DEF) (CADDR DEF) (Q *SUBR)))
00200
00300 (DFUNC (DO*FEXPR DEF) (PUTPROP (CADR DEF) (CADDR DEF) (Q *FSUBR)))
00400
00500 (DFUNC (DOACT XPR) ((GETPROP (CAR XPR) (Q COMPACTION)) XPR))
00600
00700 (DFUNC (DODE XPR) (DEFEXPR (LIST (Q DEFPROP)
00800 (CADR XPR)
00900 (LIST (Q LAMBDA) (CADDR XPR) (CADDDR XPR)))))
01000
01100 (DFUNC (DODF XPR) (DEFFEXPR (LIST (Q DEFPROP)
01200 (CADR XPR)
01300 (LIST (Q LAMBDA) (CADDR XPR) (CADDDR XPR)))))
01400
01500 (DFUNC (DOFILE DOREADS INFILE OUTFILE)
01600 (PROG (LINCNT)
01700 (SETQ LINCNT 0)
01800 (EVAL (MCONS (Q INPUT) (Q INCHAN) INFILE))
01900 (EVAL (MCONS (Q OUTPUT) (Q OUTCHAN) OUTFILE))
02000 (INC (QUOTE INCHAN) NIL)
02100 (OUTC (QUOTE OUTCHAN) NIL)
02200 (DOREADS)
02300 (OUTC NIL T)
02400 (INC NIL T)))
02500
02600 (DFUNC (FLUSHEXPR EXPR) (PROG NIL (CARRET) (PRINTEXPR EXPR) (CARRET) (LINEF)))
02700
02800 (DFUNC (FLUSHLAP LC) (PRINTLAP (READLAP LC)))
02900
03000 (DFUNC (MSGSINK) MSGDEV)
03100
03200 (DFUNC (PRINSTTY MESSAGE) (PROG (CHAN LINCNT)
03300 (SETQ CHAN (OUTC (MSGSINK) NIL))
03400 (SETQ LINCNT 0)
03500 (PRINS MESSAGE)
03600 (OUTC CHAN NIL)))
03700
03800 (DFUNC (PRINTMSG MESSAGE)
03900 (PROG (CHAN LINCNT)
04000 (SETQ CHAN (OUTC (MSGSINK) NIL))
04100 (SETQ LINCNT 0)
04200 (PRINT MESSAGE)
04300 (LINEF)
04400 (OUTC CHAN NIL)))
04500
00100 (DFUNC (READLOOP ACTFUNC) (PROG (EXPR)
00200 LOOP (SETQ EXPR (ERRSET (READ)))
00300 (COND ((EQ EXPR (Q $EOF$)) (RETURN NIL)))
00400 (ACTFUNC (CAR EXPR))
00500 (GO LOOP)))
00600
00700 (DEFPROP SPECIAL (LAMBDA (X) (MAPCAR (FUNCTION MAKESPECIAL) X)) FEXPR)
00800
00900 (DFUNC (TELLTALE FILENAME)
01000 (PROG (CHAN)
01100 (SETQ CHAN (OUTC (MSGSINK) NIL))
01200 (LINEF)
01300 (LINEF)
01400 (PRINL (LIST FILENAME (Q COMPILED)))
01500 (PRINL (LIST CODESIZE (Q WORDS)))
01600 (PRINL (LIST CONSTSIZE (Q CONSTANTS)))
01700 (PRINL (LIST (QUOTIENT (DIFFERENCE (TIME) STARTTIME) 1000.)
01800 (Q SECONDS)))
01900 (LINEF)
02000 (LINEF)
02100 (PRINL (Q (UNDEFINED FUNCTIONS)))
02200 (LINEF)
02300 (MAPC (FUNCTION (LAMBDA (X)
02400 (COND ((NOT (GETL X
02500 (Q (*SUBR *FSUBR *LSUBR EXPR FEXPR SUBR FSUBR LSUBR))))
02600 (PRINS X)))))
02700 UNDFUNS)
02800 (LINEF)
02900 (LINEF)
03000 (PRINL (Q (GENERATED FUNCTIONS)))
03100 (LINEF)
03200 (PRINL GENFUNS)
03300 (LINEF)
03400 (LINEF)
03500 (OUTC CHAN NIL)))
03600
03700 (DEFPROP UNSPECIAL (LAMBDA (X) (MAPCAR (FUNCTION MAKEUNSPECIAL) X)) FEXPR)
03800
00100 (MAPDEF COMPEFFECT
00200 ((COMPACTION DOACT) (MACRO ACTONMACRO)))
00300
00400 (MAPDEF COMPACTION
00500 ((COND EVAL)
00600 (DE DODE)
00700 (DF DODF)
00800 (DM EVAL)
00900 (DEFPROP COMPDEF)
01000 (LAP FLUSHLAP)
01100 (SPECIAL EVAL)
01200 (UNSPECIAL EVAL)))
01300
01400 (MAPDEF DEFACTION
01500 ((EXPR DEFEXPR) (FEXPR DEFFEXPR) (MACRO EVAL) (SPECIAL EVAL) (*EXPR DO*EXPR) (*FEXPR DO*FEXPR)))
01600 (SETQ LISTING NIL)
01700
01800 (SETQ MSGDEV NIL)
01900
02000 (SETQ OUTDEV (SETQ INDEV (READLIST (APPEND (EXPLODE (QUOTE DSK)) (LIST (ASCII 72))))))
02100
02200 (ENDBLOCK TOPLEVEL)
02300
00100 (BEGINBLOCK PASS1)
00200
00300 (DFUNC (DOP1 XPR) ((GETPROP (CAR XPR) (Q P1)) XPR))
00400
00500 (DFUNC (GENFUN FUNXPR)
00600 (PROG (NAME LAMLIS CALL)
00700 (COND ((ATOM FUNXPR) (RETURN FUNXPR)))
00800 (COND ((NOT (EQ (CAR FUNXPR) (Q LAMBDA)))
00900 (DATAERR NOTLAMBDA-GENFUN)))
01000 (SETQ LAMLIS (CADR FUNXPR))
01100 (SETQ CALL (CADDR FUNXPR))
01200 (COND ((AND (ATOM (CAR CALL)) (EQUAL LAMLIS (CDR CALL)))
01300 (RETURN (CAR CALL))))
01400 (SETQ NAME (GENFUNNAME))
01500 (SETQ GENFUNS (CONS NAME GENFUNS))
01600 (RETURN (COMPFUNC NAME FUNXPR (Q SUBR) (Q *SUBR)))))
01700
01800 (DFUNC (ITERCONS ARGS)
01900 (COND ((NULL ARGS) NIL)
02000 ((NULL (CDR ARGS)) (CONS (Q NCONS) ARGS))
02100 (T (LIST (Q CONS) (CAR ARGS) (ITERCONS (CDR ARGS))))))
02200
02300 (DFUNC (MAPP1 ARGS) (MAPCAR (FUNCTION P1) ARGS))
02400
02500 (DFUNC (NEWNAME OLD) (PROG (NEW)
02600 (SETQ NEW (ASSOC OLD RENAMELIST))
02700 (COND (NEW (RETURN (CDR NEW))))
02800 (RETURN NIL)))
02900
00100 (DFUNC (P1 XPR)
00200 (PROG (TEMP)
00300 (COND ((ATOM XPR) (GO ATOM)))
00400 (COND ((ATOM (CAR XPR)) (GO ATOMCAR)))
00500 (COND ((EQ (CAAR XPR) (QUOTE LAMBDA)) (RETURN (P1LAM XPR))))
00600 (COND ((EQ (CAAR XPR) (QUOTE LABEL)) (RETURN (P1LABEL XPR))))
00700 (RETURN (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))
00800 ATOM (COND ((CONSTANTP XPR) (RETURN (LIST (QUOTE QUOTE) XPR))))
00900 (COND ((SETQ TEMP (NEWNAME XPR)) (RETURN (P1 (CAR TEMP)))))
01000 (INCR P1CNT)
01100 (COND ((SPECIALP XPR) (SETQ SPECVARS (ADDTOLIST XPR SPECVARS))
01200 (RETURN XPR)))
01300 (COND ((VARB XPR) (RETURN XPR)))
01400 (PUTLOC XPR P1CNT)
01500 (RETURN XPR)
01600 ATOMCAR
01700 (COND ((CONSTANTP (CAR XPR)) (DATAERR CONSTFUN-P1)))
01800 (COND ((SETQ TEMP (NEWNAME (CAR XPR)))
01900 (RETURN (P1 (CONS (CAR TEMP) (CDR XPR))))))
02000 (COND ((SETQ TEMP (GETGET (CAR XPR) (Q PASS1)))
02100 (SETQ P1FUN TEMP)
02200 (RETURN ((CAR TEMP) XPR))))
02300 (COND ((OR (SPECIALP (CAR XPR)) (MEMBER (CAR XPR) ALLVARS))
02400 (RETURN (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))))
02500 (RETURN (P1ELSE XPR))))
02600
02700 (DFUNC (P1ANDOR XPR) (PROG (TEM CT ARGS)
02800 (SETQ TEM LOCVARS)
02900 (SETQ CT P1CNT)
03000 (SETQ ARGS (MAPP1 (CDR XPR)))
03100 (INCR P1CNT)
03200 (P1BUG CT P1CNT TEM)
03300 (INCR P1CNT)
03400 (RETURN (CONS (CAR XPR) ARGS))))
03500
03600 (DFUNC (P1BIND Z)
03700 (PROG (J NEWZ)
03800 (COND ((AND Z (ATOM Z)) (DATAERR ATOMICLAMBDALIST-P1BIND)))
03900 LOOP (COND ((NULL Z) (RETURN (REVERSE NEWZ))))
04000 (SETQ J (CAR Z))
04100 (COND ((NOT (VARIABLEP J)) (DATAERR NOTVARIABLE-P1BIND)))
04200 (COND ((SPECIALP J) (SETQ SPECVARS (ADDTOLIST J SPECVARS))
04300 (GO ELOOP))
04400 ((MEMBER J ALLVARS) (RENAME J (SETQ J (GENSYM)))))
04500 (PUTLOC J 0)
04600 ELOOP(SETQ ALLVARS (ADDTOLIST J ALLVARS))
04700 (SETQ NEWZ (CONS J NEWZ))
04800 (SETQ Z (CDR Z))
04900 (GO LOOP)))
05000
00100 (DFUNC (P1BUG LOW HIGH PTR)
00200 (PROG (X)
00300 LOOP (COND ((NULL PTR) (RETURN NIL)))
00400 (SETQ X (CAR PTR))
00500 (COND ((GREATERP (CDR X) LOW) (REPLACECDR X HIGH)))
00600 (SETQ PTR (CDR PTR))
00700 (GO LOOP)))
00800
00900 (DFUNC (P1COND XPR) (PROG (TEM CT PAIRS P1SCV)
01000 (SETQ TEM LOCVARS)
01100 (SETQ CT P1CNT)
01200 (SETQ PAIRS (MAPCAR (FUNCTION MAPP1) (CDR XPR)))
01300 (INCR P1CNT)
01400 (P1BUG CT P1CNT TEM)
01500 (INCR P1CNT)
01600 (RETURN (MCONS (CAR XPR) P1SCV PAIRS))))
01700
01800 (DFUNC (P1CONS XPR)
01900 (PROG NIL
02000 (COND ((NOT (EQ (LENGTH (CDR XPR)) 2)) (BARF ARGNOERR-P1CONS)))
02100 (COND ((NULL (CADDR XPR))
02200 (RETURN (LIST (Q NCONS) (P1 (CADR XPR))))))
02300 (RETURN (LIST (Q CONS) (P1 (CADR XPR)) (P1 (CADDR XPR))))))
02400
00100 (DFUNC (P1ELSE XPR) (PROG NIL
00200 (SETQ UNDFUNS (CONS (CAR XPR) UNDFUNS))
00300 (PUTPROP (CAR XPR) T (QUOTE *UNDEF))
00400 (RETURN (CONS (CAR XPR) (P1SUBRARGS (CDR XPR))))))
00500
00600 (DFUNC (P1ERRSET XPR)
00700 (PROG NIL
00800 (COND ((ATOM (CADR XPR)) (RETURN XPR)))
00900 (RETURN (CONS (CAR XPR) (CONS (LIST (GENFUN (LIST (Q LAMBDA)
01000 NIL
01100 (CADR XPR))))
01200 (CDDR XPR))))))
01300
01400 (DFUNC (P1EVAL XPR)
01500 (PROG (CDRXPR)
01600 (SETQ CDRXPR (P1SUBRARGS (CDR XPR)))
01700 (COND ((NOT (NULL (CDR CDRXPR))) (RETURN (CONS (Q EVAL) CDRXPR))))
01800 (RETURN (CONS (Q *EVAL) CDRXPR))))
01900
02000 (DFUNC (P1FSUBR XPR) XPR)
02100
02200 (DFUNC (P1FUNCTION XPR)
02300 (PROG (WHICH)
02400 (SETQ WHICH (ASSOC (CAR XPR)
02500 (Q ((FUNCTION QUOTE) (*FUNCTION *FUNCTION)))))
02600 (RETURN (LIST (CADR WHICH) (GENFUN (CADR XPR))))))
02700
02800 (DFUNC (P1FUNVAR XPR)
02900 (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR)))))
03000
00100 (DFUNC (P1GO XPR) (PROG NIL
00200 (COND ((NOT INPROG) (DATAERR GONOTINPROG-P1GO)))
00300 (COND ((ATOM (CADR XPR)) (RETURN XPR)))
00400 (RETURN (LIST (CAR XPR) (P1 (CADR XPR))))))
00500
00600 (DFUNC (P1LABEL XPR)
00700 (PROG (FN)
00800 (PUTPROP (CADAR XPR) T (Q FUNVAR))
00900 (SETQ FN (P1 (LIST (Q FUNCTION) (CADDAR XPR))))
01000 (REMPROP (CADAR XPR) (Q FUNVAR))
01100 (RETURN (P1 (LIST (Q PROG)
01200 (LIST (CADAR XPR))
01300 (LIST (Q SETQ) (CADAR XPR) FN)
01400 (LIST (QUOTE RETURN)
01500 (CONS (CADAR XPR) (CDR XPR))))))))
01600
01700 (DFUNC (P1LAM XPR) (PROG (ARGS LAML BODY SAVERENAMELIST)
01800 (SETQ SAVERENAMELIST RENAMELIST)
01900 (SETQ ARGS (P1SUBRARGS (CDR XPR)))
02000 (SETQ LAML (P1BIND (CADAR XPR)))
02100 (SETQ BODY (P1 (CADDAR XPR)))
02200 (SETQ P1CNT (ADD1 P1CNT))
02300 (SETQ RENAMELIST SAVERENAMELIST)
02400 (RETURN (CONS (LIST (Q LAMBDA) LAML BODY) ARGS))))
02500
02600 (DFUNC (P1LSUBR XPR) (CONS (CAR XPR) (MAPP1 (CDR XPR))))
02700
02800 (DFUNC (P1*MACRO XPR) (P1 ((GETPROP (CAR XPR) (Q *MACRO)) XPR)))
02900
03000 (DFUNC (P1MACRO XPR) (P1 ((GETPROP (CAR XPR) (Q MACRO)) XPR)))
03100
00100 (DFUNC (P1PROG X)
00200 (PROG (TAGLIST P1SCNT PR TEM P1LL INPROG SAVERENAMELIST)
00300 (COND ((NULL (CDR X)) (DATAERR PROGTOOSHORT-P1PROG)))
00400 (SETQ INPROG T)
00500 (SETQ X (CDR X))
00600 (SETQ SAVERENAMELIST RENAMELIST)
00700 (SETQ P1LL (P1BIND (CAR X)))
00800 (SETQ TEM LOCVARS)
00900 (SETQ P1SCNT (INCR P1CNT))
01000 LOOP1(SETQ X (CDR X))
01100 (COND ((NULL X) (GO END1)))
01200 (INCR P1CNT)
01300 (COND ((ATOM (CAR X))
01400 (COND ((ASSOC (CAR X) TAGLIST) (DATAERR MDT-P1PROG)))
01500 (SETQ TAGLIST (CONS (CONS (CAR X) (GENTAG)) TAGLIST))
01600 (SETQ PR (CONS (CAR X) PR)))
01700 (T (SETQ PR (CONS (P1 (CAR X)) PR))))
01800 (GO LOOP1)
01900 END1 (INCR P1CNT)
02000 (P1BUG P1SCNT P1CNT TEM)
02100 (SETQ TEM (GETPROP (Q LOCVARS) (Q VALUE)))
02200 LOOP (COND ((NULL (CDR TEM)) (GO END)))
02300 (COND ((NOT (AND (MEMBER (CAADR TEM) P1LL) (ZEROP (CDADR TEM))))
02400 (GO ELOOP)))
02500 (SETQ SPECVARS (ADDTOLIST (CAADR TEM) SPECVARS))
02600 (PRINTMSG (LIST (CAADR TEM) (QUOTE UNUSEDPROGVAR)))
02700 (MAKESPECIAL (CAADR TEM))
02800 (REPLACECDR TEM (CDDR TEM))
02900 (GO LOOP)
03000 ELOOP(SETQ TEM (CDR TEM))
03100 (GO LOOP)
03200 END (INCR P1CNT)
03300 (SETQ RENAMELIST SAVERENAMELIST)
03400 (RETURN (MCONS (QUOTE PROG) TAGLIST P1LL (REVERSE PR)))))
03500
03600 (DFUNC (P1RETURN XPR)
03700 (PROG NIL
03800 (COND ((NOT INPROG) (DATAERR RETURNNOTINPROG-P1RETURN)))
03900 (COND ((NULL (CDR XPR)) (DATAERR NOARG-P1RETURN)))
04000 (RETURN (LIST (Q RETURN) (P1 (CADR XPR))))))
04100
00100 (DFUNC (P1SETQ XPR)
00200 (PROG (VAR TEM VAL)
00300 (COND ((NOT (VARIABLEP (CAR XPR))) (DATAERR NONVARIABLE-P1SETQ)))
00400 (SETQ VAR (COND ((SETQ TEM (NEWNAME (CADR XPR))) (CAR TEM))
00500 (T (CADR XPR))))
00600 (VARB VAR)
00700 (SETQ P1SCV (CONS VAR P1SCV))
00800 (SETQ VAL (P1 (CADDR XPR)))
00900 (SETQ P1CNT (PLUS 2 P1CNT))
01000 (RETURN (LIST (Q SETQ) VAR VAL))))
01100
01200 (DFUNC (P1STORE XPR)
01300 (PROG (ARG1 ARG2)
01400 (SETQ ARG2 (P1 (CADDR XPR)))
01500 (SETQ ARG1 (P1 (CADR XPR)))
01600 (RETURN (LIST (CAR XPR) ARG1 ARG2))))
01700
01800 (DFUNC (P1SUBR XPR) (CONS (CAR XPR) (P1SUBRARGS (CDR XPR))))
01900
02000 (DFUNC (P1SUBRARGS ARGLST) (PROG NIL
02100 (COND ((GREATERP (LENGTH ARGLST) NACS)
02200 (DATAERR TOOMANYARGS-P1SUBRARGS)))
02300 (RETURN (MAPP1 ARGLST))))
02400
00100 (DFUNC (PASS1 EXP)
00200 (PROG (ALLVARS LL RENAMELIST P1SCNT P1SCV INPROG FOUNDFREE)
00300 (SETQ INPROG NIL)
00400 (SETQ P1CNT 1)
00500 (SETQ LOCVARS (SETQ SPECVARS NIL))
00600 (COND ((EQ FUNTYPE (Q *LSUBR))
00700 (SETQ EXP (CONS (CAR EXP)
00800 (CONS (LIST (CADR EXP)) (CDDR EXP))))))
00900 (SETQ LL (P1BIND (CADR EXP)))
01000 (COND ((GREATERP (LENGTH LL) NACS) (BARF TOOMANYARGS-PASS1)))
01100 (SETQ EXP (LIST (CAR EXP) LL (P1 (CADDR EXP))))
01200 (COND ((NOT (NULL FOUNDFREE))
01300 (PRINTMSG (CONS (Q SPECIAL) (REVERSE FOUNDFREE)))))
01400 (RETURN EXP)))
01500
01600 (DFUNC (PUTLOC IVAR NUMBER)
01700 (PROG (TEM)
01800 (SETQ TEM (ASSOC IVAR LOCVARS))
01900 (COND (TEM (RETURN (REPLACECDR TEM NUMBER))))
02000 (RETURN (SETQ LOCVARS (CONS (CONS IVAR NUMBER) LOCVARS)))))
02100
02200 (DFUNC (RENAME OLD NEW) (SETQ RENAMELIST (CONS (LIST OLD NEW) RENAMELIST)))
02300
02400 (DFUNC (SPECIALP VAR) (HASPROP VAR (Q SPECIAL)))
02500
02600 (DFUNC (VARB X)
02700 (PROG NIL
02800 (COND ((MEMBER X ALLVARS) (RETURN NIL)) ((SPECIALP X) (GO SPEC)))
02900 (SETQ FOUNDFREE (CONS X FOUNDFREE))
03000 (MAKESPECIAL X)
03100 SPEC (SETQ SPECVARS (ADDTOLIST X SPECVARS))
03200 (SETQ ALLVARS (ADDTOLIST X ALLVARS))
03300 (RETURN T)))
03400
03500 (DFUNC (VARIABLEP EX) (AND (ATOM EX) (NOT (CONSTANTP EX))))
03600
00100 (MAPDEF PASS1
00200 ((EXPR P1SUBR) (SUBR P1SUBR)
00300 (*SUBR P1SUBR)
00400 (*UNDEF P1SUBR)
00500 (LSUBR P1LSUBR)
00600 (*LSUBR P1LSUBR)
00700 (FEXPR P1FSUBR)
00800 (FSUBR P1FSUBR)
00900 (*FSUBR P1FSUBR)
01000 (FUNVAR P1FUNVAR)
01100 (P1 DOP1)
01200 (MACRO P1MACRO)
01300 (*MACRO P1*MACRO)))
01400
01500 (MAPDEF P1
01600 ((COND P1COND) (GO P1GO)
01700 (PROG P1PROG)
01800 (EVAL P1EVAL)
01900 (ERRSET P1ERRSET)
02000 (SETQ P1SETQ)
02100 (STORE P1STORE)
02200 (AND P1ANDOR)
02300 (CONS P1CONS)
02400 (OR P1ANDOR)
02500 (*FUNCTION P1FUNCTION)
02600 (FUNCTION P1FUNCTION)
02700 (RETURN P1RETURN)))
02800
02900 (BEGINBLOCK *MACRO)
03000
03100 (DEFPROP APPEND
03200 (LAMBDA (L)
03300 (COND ((NULL (CDR L)) NIL)
03400 ((NULL (CDDR L)) (CADR L))
03500 (T (LIST (QUOTE *APPEND) (CADR L) (CONS (CAR L) (CDDR L))))))
03600 *MACRO)
03700
03800 (DEFPROP LIST (LAMBDA (L) (ITERCONS (CDR L))) *MACRO)
03900
04000 (DEFPROP NOT (LAMBDA (L) (CONS (QUOTE NULL) (CDR L))) *MACRO)
04100
04200 (ENDBLOCK *MACRO)
04300
04400 (ENDBLOCK PASS1)
04500
00100 (BEGINBLOCK PASS2)
00200
00300 (DFUNC (ACEFFECTS FN)
00400 (COND ((SETQ FN (SEEKPROP FN (Q ACS))) (PROPVAL FN))
00500 (T ALLACS)))
00600
00700 (DFUNC (ACNUMP X) (AND (NUMBERP X) (GREATERP X 0) (LESSP X (ADD1 NACS))))
00800
00900 (DFUNC (BINDVARS VARS LAMBDAP)
01000 (PROG (VAR ACNUM SPFLG1)
01100 (SETQ ACNUM 1)
01200 A (COND ((NULL VARS) (RETURN SPFLG1)))
01300 (SETQ VAR (CAR VARS))
01400 (COND ((SPECVARP VAR) (GO SP1))
01500 ((ASSOC VAR LOCVARS) (GO LV1))
01600 (T (BARF FUNNYVAR-BINDVARS) (GO SP2)))
01700 LV1 (COND (LAMBDAP (SETSLOT ACNUM (LIST VAR))))
01800 SP2 (SETQ ACNUM (ADD1 ACNUM))
01900 (SETQ VARS (CDR VARS))
02000 (GO A)
02100 SP1 (COND ((NOT PRGSPFLG) (GO B)))
02200 SP3 (OUTINST (LIST 0
02300 (COND (LAMBDAP ACNUM) (T 0))
02400 (LIST (QUOTE SPECIAL) VAR)))
02500 (GO LV1)
02600 B (SETQ PRGSPFLG (SETQ SPFLG1 T))
02700 (OUTINST (QUOTE (JSP 6 SPECBIND)))
02800 (GO SP3)))
02900
00100 (DFUNC (BOOLAND EXP VALAC TAG FLAG) (PROG NIL
00200 (BOOL2 (CDR EXP) VALAC TAG T FLAG)
00300 (SETQ P2CNT (PLUS 2 P2CNT))))
00400
00500 (DFUNC (BOOLEQ EXP VALAC TAG FLAG)
00600 (PROG NIL
00700 (BOOLEQ1 (CDR EXP) VALAC TAG FLAG)
00800 (OUTJRST TAG)
00900 (RSLSET TAG)
01000 (RETURN NIL)))
01100
01200 (DFUNC (BOOLEQ1 EXP VALAC TAG F)
01300 (PROG (ARG1 ARG2 ARG1LOC ARG2LOC AC MEM)
01400 (SETQ ARG1 (COMP (CAR EXP) (FREEAC)))
01500 (SETQ ARG2 (COMP (CADR EXP) (FREEAC)))
01600 (SETQ ARG2LOC (ILOC1 ARG2 (FREEAC)))
01700 (SETQ ARG1LOC (ILOC1 ARG1 (FREEAC)))
01800 (COND ((ACNUMP ARG1LOC) (SETQ AC ARG1LOC)
01900 (REMOVE ARG1)
02000 (COND ((ACNUMP ARG2LOC) (REMOVE ARG2)))
02100 (RST TAG)
02200 (SETQ MEM (LOC ARG2))
02300 (GO A))
02400 ((ACNUMP ARG2LOC) (REMOVE ARG2) (SETQ AC ARG2LOC) (RST TAG) (SETQ MEM (LOC ARG1)) (GO A)))
02500 (LOADARG (SETQ AC (FREEAC)) ARG1)
02600 (RST TAG)
02700 (SETQ MEM (LOC ARG2))
02800 (GO B)
02900 A (REMOVE ARG1)
03000 B (REMOVE ARG2)
03100 (SAVEACS)
03200 (OUT1 (COND (F (QUOTE CAMN)) (T (QUOTE CAME))) AC MEM)))
03300
03400 (DFUNC (BOOLEXPR EXP VALAC TAG FLAG MINDEPTH)
03500 (PROG (TEM)
03600 (COND ((ATOM EXP) (GO ELSE)))
03700 (COND ((SETQ TEM (SEEKPROP (CAR EXP) (Q BOOL)))
03800 (SETQ BOOLFUN (PROPVAL TEM))
03900 (RETURN ((PROPVAL TEM) EXP VALAC TAG FLAG))))
04000 ELSE (SETQ EXP (PUTINAC (COMP EXP VALAC) (COND (VALAC) ((FREEAC)))))
04100 (OUTCJMP FLAG EXP TAG)
04200 (COND (FLAG (RSLSET TAG) (SETSLOT EXP (QUOTE (QUOTE NIL))))
04300 (T (SETQ FLAG (SLOTCONT EXP))
04400 (SETSLOT EXP (QUOTE (QUOTE NIL)))
04500 (RSLSET TAG)
04600 (SETSLOT EXP FLAG)))))
04700
00100 (DFUNC (BOOL2 EXP VALAC TAG F1 F2)
00200 (PROG (G)
00300 (CLEAR1)
00400 (PUTPROP (SETQ G (GENTAG)) (TOPCOPY REGPDL) (QUOTE LEVEL))
00500 A (COND ((NULL EXP) (COND (F2 (OUTJRST TAG))) (GO C)))
00600 (COND ((AND F2 (NULL (CDR EXP))) (GO B)))
00700 (BOOLEXPR (CAR EXP) VALAC (COND (F2 G) (T TAG)) (NOT F1) MINDEPTH)
00800 (SETQ EXP (CDR EXP))
00900 (GO A)
01000 B (BOOLEXPR (CAR EXP) VALAC TAG F1 MINDEPTH)
01100 (OUTENDTAG G)
01200 C (CLEAR2BOTH)
01300 (CLRARGACS)))
01400
01500 (DFUNC (BOOLNULL EXP VALAC TAG FLAG)
01600 (BOOLEXPR (CADR EXP) VALAC TAG (NOT FLAG) MINDEPTH))
01700
01800 (DFUNC (BOOLOR EXP VALAC TAG FLAG)
01900 (PROG NIL
02000 (BOOL2 (CDR EXP) VALAC TAG NIL (NOT FLAG))
02100 (SETQ P2CNT (PLUS 2 P2CNT))))
02200
02300 (DFUNC (BOOLQUOTE EXP VALAC TAG FLAG)
02400 (BOOL2 NIL VALAC TAG NIL (IFIF FLAG (CADR EXP))))
02500
02600 (DFUNC (BOOLVALUE VALAC EFFECTS TAG)
02700 (PROG NIL
02800 (COND ((NOT EFFECTS) (OUT1 (QUOTE TDZA) VALAC VALAC)))
02900 (OUTENDTAG TAG)
03000 (COND ((NOT EFFECTS)
03100 (OUT1 (QUOTE MOVEI) VALAC (QUOTE (QUOTE T)))))
03200 (RETURN (COND (EFFECTS NIL) (T (VALLOC VALAC))))))
03300
00100 (DFUNC (CALLFSUBR XPR VALAC EFFECTS)
00200 (PROG (FUN ARGS VAL)
00300 (SETQ FUN (CAR XPR))
00400 (SETQ ARGS (CDR XPR))
00500 (CLEAR2BOTH)
00600 (LOADARG FARGAC (LIST (Q QUOTE) ARGS))
00700 (PROTECTACS FUN)
00800 (COND ((NOT (NULL VALAC)) (SETQ VAL (VALLOC VALUEAC))))
00900 (OUTCALL 17 FUN)
01000 (RETURN VAL)))
01100
01200 (DFUNC (CALLFUNARGS XPR VALAC EFFECTS)
01300 (PROG (FUN ARGS FUNARGS LOCS VAL)
01400 (SETQ FUN (CAR XPR))
01500 (SETQ ARGS (CDR XPR))
01600 (SETQ FUNARGS (COMP FUN VALAC))
01700 (SETQ LOCS (COMPARGS ARGS))
01800 (CLRCCLST LOCS)
01900 (LOADSUBRARGS LOCS)
02000 (CLEAR2BOTH)
02100 (CLRARGACS)
02200 (COND ((NOT (NULL VALAC)) (SETQ VAL (VALLOC VALUEAC))))
02300 (OUTCALLF (LENGTH LOCS) (LOC FUNARGS))
02400 (REMOVE FUNARGS)
02500 (RETURN VAL)))
00100 (DFUNC (CALLLSUBR XPR VALAC EFFECTS)
00200 (PROG (FUN ARGS NARGS HOME INST RETTAG TEM VAL)
00300 (SETQ FUN (CAR XPR))
00400 (SETQ ARGS (CDR XPR))
00500 (CLEAR1)
00600 (SETQ NARGS (LENGTH ARGS))
00700 (SLOTPUSH (Q (NIL . TAKEN)))
00800 (OUTPUSH (GENCONST 0 0 (SETQ RETTAG (GENTAG)) 0 0))
00900 LOOP (COND ((NULL ARGS) (GO CALL)))
01000 (SETQ HOME (TOPCOPY REGPDL))
01100 (SETQ INST (COMP (CAR ARGS) VALAC))
01200 (RESTORE HOME)
01300 (SETQ TEM (LOC INST))
01400 (SLOTPUSH (Q (NIL . TAKEN)))
01500 (OUTPUSH TEM)
01600 (REMOVE INST)
01700 (SETQ ARGS (CDR ARGS))
01800 (GO LOOP)
01900 CALL (SETQ TEM PDLDEPTH)
02000 (SAVEACS)
02100 (COND ((NOT (EQ PDLDEPTH TEM)) (BARF PDLTOOLONG-LSUBRCALL)))
02200 (OUTINST (LIST (Q MOVNI) 6 NARGS))
02300 LLOOP(SLOTPOP)
02400 (COND ((ZEROP NARGS) (GO CALL1)))
02500 (SETQ NARGS (SUB1 NARGS))
02600 (GO LLOOP)
02700 CALL1(CLEAR2BOTH)
02800 (CLRARGACS)
02900 (COND ((NOT (NULL VALAC)) (SETQ VAL (VALLOC VALUEAC))))
03000 (OUTJCALL 16 FUN)
03100 (OUTTAG RETTAG)
03200 (RETURN VAL)))
03300
00100 (DFUNC (CALLSUBR XPR VALAC EFFECTS)
00200 (PROG (FUN ARGS NARGS LOCS TEMP VAL)
00300 (SETQ FUN (CAR XPR))
00400 (SETQ ARGS (CDR XPR))
00500 (SETQ LOCS (COMPARGS ARGS))
00600 (SETQ NARGS (LENGTH LOCS))
00700 (COND ((AND (SETQ TEMP (SEEKPROP FUN (Q COMMU)))
00800 (EQ NARGS 2)
00900 (EQ (ILOC (CAR LOCS)) VALUEAC))
01000 (SETQ LOCS (REVERSE LOCS))
01100 (SETQ FUN (PROPVAL TEMP))))
01200 (SETQ TEMP (SIDEEFFECTS FUN))
01300 (COND (TEMP (CLRCCLST LOCS)))
01400 (LOADSUBRARGS LOCS)
01500 (COND (TEMP (CLEAR2BOTH)))
01600 (PROTECTACS FUN)
01700 (COND ((NOT (NULL VALAC)) (SETQ VAL (VALLOC VALUEAC))))
01800 (OUTCALL NARGS FUN)
01900 (RETURN VAL)))
02000
02100 (DFUNC (CLEAR1)
02200 (PROG NIL (CLEAR1BOTH) (SAVEACS) (RETURN (CLRPVARS))))
02300
02400 (DFUNC (CLEAR1BOTH) (PROG NIL (CLRCCLST1 VALUEAC) (CLRSPLD)))
02500
02600 (DFUNC (CLEAR2BOTH) (PROG NIL (CLRCCLST2 VALUEAC) (CLRSPLD)))
02700
02800 (DFUNC (CLEARAC ACNO) (PROG NIL (CPUSH ACNO) (SETSLOT ACNO NIL)))
02900
03000 (DFUNC (CLEARITALL) (PROG NIL (CLEAR2BOTH) (CLRARGACS)))
03100
03200 (DFUNC (CLRARGACS) (PROG (ACNO)
03300 (SETQ ACNO NACS)
03400 LOOP (COND ((ZEROP ACNO) (RETURN NIL)))
03500 (CLEARAC ACNO)
03600 (SETQ ACNO (SUB1 ACNO))
03700 (GO LOOP)))
03800
03900 (DFUNC (CLRCCLST DATA)
04000 (PROG (CCL)
04100 (SETQ CCL CCLST)
04200 LOOP (COND ((NULL CCL) (RETURN NIL)))
04300 (COND ((ASSOC (CAAR CCL) DATA) (GO ELOOP)))
04400 (CSFUN (CAR CCL) VALUEAC)
04500 ELOOP(SETQ CCL (CDR CCL))
04600 (GO LOOP)))
04700
00100 (DFUNC (CLRCCLST1 AC)
00200 (PROG (CCL)
00300 (SETQ CCL CCLST)
00400 LOOP (COND ((NULL CCL) (RETURN NIL)))
00500 (CSFUN (CAR CCL) AC)
00600 (SETQ CCL (CDR CCL))
00700 (GO LOOP)))
00800
00900 (DFUNC (CLRCCLST2 AC)
01000 (PROG NIL
01100 LOOP (COND ((NULL CCLST) (RETURN NIL)))
01200 (CSFUN (CAR CCLST) AC)
01300 (SETQ CCLST (CDR CCLST))
01400 (GO LOOP)))
01500
01600 (DFUNC (CLRPVARS)
01700 (PROG NIL
01800 (COND ((NOT PROGSW) (RETURN NIL)))
01900 (SETQ PROGSW NIL)
02000 LOOP (COND ((NULL PROGVARS) (SETQ PRSSL (TOPCOPY REGPDL))
02100 (SETQ MINDEPTH PDLDEPTH)
02200 (RETURN NIL))
02300 ((NOT (ILOC (CONS (CAR PROGVARS) P2CNT)))
02400 (INITZ (CAR PROGVARS))))
02500 (SETQ PROGVARS (CDR PROGVARS))
02600 (GO LOOP)))
02700
02800 (DFUNC (CLRSPLD)
02900 (PROG NIL
03000 LOOP (COND ((NULL SPLDLST) (RETURN NIL)))
03100 (CLRSPVAR (CAR SPLDLST))
03200 (SETQ SPLDLST (CDR SPLDLST))
03300 (GO LOOP)))
03400
03500 (DFUNC (CLRSPVAR L)
03600 (PROG (LOC)
03700 (SETQ LOC (ILOC (CONS (CAR L) P2CNT)))
03800 (COND ((NOT (NUMBERP LOC))
03900 (OUTSPECPUSH (CAR L)))
04000 ((ACNUMP LOC)
04100 (SLOTPUSH (SLOTCONT LOC))
04200 (OUTPUSH LOC)))
04300 (RETURN NIL)))
04400
04500 (DFUNC (COMP XPR VALAC) (COMPEXPR XPR VALAC NIL))
04600
00100 (DFUNC (COMPARGS ARGS)
00200 (PROG (ARGNO RESULT)
00300 (SETQ ARGNO 0)
00400 LOOP (COND ((NULL ARGS) (RETURN RESULT)))
00500 (INCR ARGNO)
00600 (SETQ RESULT (CONS (COMP (CAR ARGS) ARGNO) RESULT))
00700 (SETQ ARGS (CDR ARGS))
00800 (GO LOOP)))
00900
01000 (DFUNC (COMPE XPR VALAC) (REMOVE (COMPEXPR XPR VALAC T)))
01100
01200 (DFUNC (COMPEXPR XPR VALAC EFFECTS)
01300 (PROG (TEMP)
01400 (COND ((ATOM XPR) (GO ATOM)))
01500 (COND ((ATOM (CAR XPR)) (GO ATOMCAR)))
01600 (COND ((EQ (CAAR XPR) (QUOTE LAMBDA))
01700 (RETURN (P2LAM XPR VALAC EFFECTS))))
01800 (RETURN (CALLFUNARGS XPR VALAC EFFECTS))
01900 ATOM (SETQ TEMP (CONS XPR (INCR P2CNT)))
02000 (COND ((SPECVARP XPR) (SETQ SPLDLST (CONS TEMP SPLDLST))))
02100 (SETQ LDLST (CONS TEMP LDLST))
02200 (RETURN TEMP)
02300 ATOMCAR
02400 (COND ((SETQ TEMP (GETGET (CAR XPR) (Q PASS2)))
02500 (SETQ P2FUN TEMP)
02600 (RETURN ((CAR TEMP) XPR VALAC EFFECTS))))
02700 (COND ((OR (SPECVARP (CAR XPR)) (ASSOC (CAR XPR) LOCVARS))
02800 (RETURN (CALLFUNARGS XPR VALAC EFFECTS))))
02900 (RETURN (P2ELSE XPR VALAC EFFECTS))))
03000
03100 (DFUNC (COPT X Y) (PROG (CCL TEM YLOC)
03200 (SETQ YLOC (ILOC Y))
03300 (SETQ CCL CCLST)
03400 LOOP (COND ((NULL CCL) (RETURN NIL))
03500 ((AND (EQ X (CADAR CCL))
03600 (EQUAL (ILOC (CDDAR CCL)) YLOC)
03700 (ILOC (SETQ TEM (LIST (CAAR CCL)))))
03800 (RETURN TEM)))
03900 (SETQ CCL (CDR CCL))
04000 (GO LOOP)))
00100 (DFUNC (CPUSH ACNO)
00200 (PROG (TEMPPDL SLOTNO SLOTCON HOLDSLOT)
00300 (COND ((NOT (DVP (SETQ SLOTCON (SLOTCONT ACNO)))) (RETURN NIL)))
00400 (COND ((LESSP ACNO 1) (GO MAKESLOT)))
00500 START(SETQ SLOTNO 0)
00600 (SETQ TEMPPDL REGPDL)
00700 LOOP (COND ((NULL TEMPPDL) (GO NOSLOT)))
00800 (COND ((DVP (CAR TEMPPDL)) (GO ELOOP)))
00900 (COND ((OR (NOT (NUMBERP (CDAR TEMPPDL)))
01000 (SPECVARP (CAAR TEMPPDL)))
01100 (SETQ HOLDSLOT SLOTNO)))
01200 (COND ((EQ (CAR SLOTCON) (CAAR TEMPPDL)) (GO FOUNDSLOT)))
01300 ELOOP(SETQ TEMPPDL (CDR TEMPPDL))
01400 (SETQ SLOTNO (SUB1 SLOTNO))
01500 (GO LOOP)
01600 FOUNDSLOT
01700 (SETSLOT SLOTNO SLOTCON)
01800 (SETSLOT ACNO (CONS (CAR SLOTCON) (Q DUP)))
01900 (OUTMOVEM ACNO SLOTNO)
02000 (RETURN NIL)
02100 NOSLOT
02200 (COND (HOLDSLOT (SETQ SLOTNO HOLDSLOT) (GO FOUNDSLOT)))
02300 MAKESLOT
02400 (COND ((AND PROGSW (NOT (ASSOC (CAR SLOTCON) LOCVARS)))
02500 (SETQ TEMPPDL PDLDEPTH)
02600 (CLRPVARS)
02700 (COND ((LESSP ACNO 1)
02800 (SETQ ACNO
02900 (PLUS ACNO (DIFFERENCE TEMPPDL PDLDEPTH)))))))
03000 (SLOTPUSH SLOTCON)
03100 (SETSLOT ACNO (CONS (CAR SLOTCON) (Q DUP)))
03200 (OUTPUSH ACNO)
03300 (RETURN NIL)))
03400
03500 (DFUNC (CSFUN L AC)
03600 (PROG (Y) (COND ((AND (SETQ Y (ASSOC (CAR L) LDLST)) (NOT (ILOC Y)))
03700 (LOADCARCDR L AC)))))
03800
03900 (DFUNC (CSTEP FUN AC ARGLOC)
04000 (PROG (TEM)
04100 (COND ((NULL FUN) (RETURN (LIST ARGLOC))))
04200 (COND ((SETQ TEM (COPT FUN ARGLOC)) (RETURN (LIST TEM))))
04300 (RETURN (CONS (CAR (SETQ TEM
04400 (GETPROP FUN (Q CARCDRPROP))))
04500 (CSTEP (CDR TEM) AC ARGLOC)))))
04600
00100 (DFUNC (DOP2 XPR VALAC EFFECTS) ((GETPROP (CAR XPR) (Q P2)) XPR VALAC EFFECTS))
00200
00300 (DFUNC (DVP X)
00400 (PROG (Y Z)
00500 (COND ((NULL X) (RETURN NIL)))
00600 (COND ((EQ (CAR X) (QUOTE QUOTE)) (RETURN NIL)))
00700 (COND ((EQ (CDR X) (QUOTE TAKEN)) (RETURN T)))
00800 (COND ((EQ (CDR X) (QUOTE DUP)) (RETURN NIL)))
00900 (COND ((AND (SPECVARP (CAR X)) (NULL (CDR X))) (RETURN NIL)))
01000 (COND ((AND (SETQ Y (ASSOC (CAR X) LOCVARS))
01100 (NULL (CDR X))
01200 (LESSP P2CNT (CDR Y)))
01300 (RETURN T)))
01400 (SETQ Z LDLST)
01500 LOOP (COND ((NULL Z) (RETURN (COND ((SETQ Z (ASSOC (CAR X) VARLIST))
01600 (DVP (CONS (CDR Z) (CDR X))))
01700 (T NIL)))))
01800 (COND ((AND (EQ (CAAR Z) (CAR X))
01900 (EQUAL (LOC (COND ((NUMBERP (CDR X)) X)
02000 (T (CONS (CAR X) P2CNT))))
02100 (LOC (CAR Z))))
02200 (RETURN T)))
02300 (SETQ Z (CDR Z))
02400 (GO LOOP)))
02500
02600 (DFUNC (EQUIVTAG TG) (PROG (Z)
02700 (COND ((SETQ Z (ASSOC TG GOLIST)) (RETURN (CDR Z))))
02800 (PRINTMSG (LIST (QUOTE UNDEFINED) (QUOTE TAG) TG))
02900 (RETURN EXIT)))
00100 (DFUNC (EXITBUM SPECFLAG)
00200 (PROG (TEM1 TEM2)
00300 (COND ((SETQ TEM1 (ASSOC (CAAR LASTOUT)
00400 (Q ((CALL JCALL) (PUSHJ JRST)))))
00500 (SETQ TEM2 (CAR LASTOUT))
00600 (SETQ LASTOUT NIL)
00700 (KILLPDL)
00800 (OUTINST TEM2)
00900 (COND ((NOT SPECFLAG)
01000 (SETQ TEM2 (CAR LASTOUT))
01100 (SETQ LASTOUT NIL)
01200 (OUTINST (MCONS (CADR TEM1)
01300 (SUBST 0 PDLAC (CADR TEM2))
01400 (CDDR TEM2)))
01500 (RETURN NIL)))))
01600 (KILLPDL)
01700 (COND (SPECFLAG (OUTINST (QUOTE (JRST 0 SPECSTR))))
01800 (T (OUTINST (QUOTE (POPJ P)))))))
01900
02000 (DFUNC (FREEAC) (FREEAC1 NIL))
02100
02200 (DFUNC (FREEAC1 BESTAC) (PROG (ACNO ACS IT)
02300 (COND ((NULL BESTAC) (SETQ IT NACS))
02400 ((NOT (DVP (SLOTCONT BESTAC))) (RETURN BESTAC))
02500 (T (SETQ IT BESTAC)))
02600 (SETQ ACS ARGACS)
02700 (SETQ ACNO 0)
02800 LOOP (SETQ ACNO (ADD1 ACNO))
02900 (COND ((NULL ACS) (CPUSH IT) (RETURN IT)))
03000 (COND ((NULL (CAR ACS)) (RETURN ACNO)))
03100 (COND ((NOT (DVP (CAR ACS))) (SETQ IT ACNO)))
03200 (SETQ ACS (CDR ACS))
03300 (GO LOOP)))
03400
00100 (DFUNC (FREEZE VAR) (PROG NIL (FREEZE1 VAR ARGACS) (FREEZE1 VAR REGPDL)))
00200
00300 (DFUNC (FREEZE1 X Z)
00400 (PROG NIL
00500 LP (COND ((NULL Z) (RETURN NIL))
00600 ((EQ X (CAAR Z))
00700 (COND ((OR (NULL (CDAR Z)) (EQ (CDAR Z) (Q DUP)))
00800 (REPLACECAR Z (CONS X P2CNT))))))
00900 (SETQ Z (CDR Z))
01000 (GO LP)))
01100
01200 (DFUNC (GENCONST OP AC AD IN IB)
01300 (PROG (ANS)
01400 (COND ((NOT (ZEROP IB)) (SETQ ANS (LIST *AT))))
01500 (SETQ ANS (APPEND ANS (LIST AC AD IN)))
01600 (SETQ ANS (CONS OP ANS))
01700 (RETURN (CONS (QUOTE C) ANS))))
01800
01900 (DFUNC (GETSLOT NO)
02000 (COND ((NOT (NUMBERP NO)) (BARF NOTSLOT-GETSLOT))
02100 ((GREATERP NO NACS) (PRINTMSG NO) (BARF NOTAC-GETSLOT))
02200 ((GREATERP NO 0) (NTHCDR (SUB1 NO) ARGACS))
02300 ((GREATERP (ABS NO) PDLDEPTH) (PRINTMSG NO)
02400 (BARF NOTONPDL-GETSLOT))
02500 ((NTHCDR (MINUS NO) REGPDL))))
02600
00100 (DFUNC (ILOC X)
00200 (PROG (CNTR BEST BESTNO Y SL SLOT)
00300 (SETQ SL (SLOTLIST))
00400 (SETQ CNTR 1)
00500 LOOP (COND ((NULL SL) (GO EXIT)))
00600 (SETQ SLOT (CAR SL))
00700 (COND ((AND SLOT (EQ (CAR SLOT) (CAR X))) (GO ISONE)))
00800 ELOOP(SETQ SL (CDR SL))
00900 (SETQ CNTR (ADD1 CNTR))
01000 (GO LOOP)
01100 TAKEIFN
01200 (COND (BESTNO (GO ELOOP)))
01300 (SETQ BESTNO 105105)
01400 (GO TAKEL1)
01500 TAKEL(SETQ BESTNO (CDR SLOT))
01600 TAKEL1
01700 (SETQ BEST CNTR)
01800 (GO ELOOP)
01900 EXIT (COND (BESTNO (GO RETVAL)))
02000 (COND ((SPECVARP (CAR X))
02100 (RETURN (LIST (QUOTE SPECIAL) (CAR X)))))
02200 (COND ((EQ (CAR X) (QUOTE QUOTE)) (RETURN (LIST X))))
02300 (COND ((SETQ Y (ASSOCR (CAR X) VARLIST))
02400 (RETURN (ILOC (CONS (CAR Y) (CDR X))))))
02500 (RETURN NIL)
02600 ISONE(COND ((EQ (CAR X) (QUOTE QUOTE)) (GO QT)))
02700 (COND ((NOT (NUMBERP (CDR SLOT))) (GO TAKEIFN)))
02800 (COND ((AND (NOT (LESSP (CDR SLOT) (CDR X)))
02900 (OR (NULL BESTNO) (GREATERP BESTNO (CDR SLOT))))
03000 (GO TAKEL)))
03100 (GO ELOOP)
03200 QT (COND ((NOT (EQUAL X SLOT)) (GO ELOOP)))
03300 TAKE (SETQ BEST CNTR)
03400 RETVAL
03500 (RETURN (COND ((NOT (GREATERP BEST NACS)) BEST)
03600 (T (PLUS (MINUS BEST) NACS 1))))))
03700
03800 (DFUNC (ILOC1 X AC)
03900 (PROG (Z)
04000 (COND ((SETQ Z (ILOC X)) (RETURN Z)))
04100 (COND ((MEMBER (CAR X) PROGVARS) (RETURN (QUOTE ((QUOTE NIL))))))
04200 (COND ((SETQ Z (ASSOCR (CAR X) VARLIST))
04300 (RETURN (ILOC1 (CONS (CAR Z) (CDR X)) AC))))
04400 (COND ((SETQ Z (ASSOC (CAR X) CCLST))
04500 (RETURN (LOADCARCDR Z
04600 (COND ((NULL AC) (FREEAC)) (T AC))))))
04700 (PRINTMSG X)
04800 (BARF LOSTVAR-ILOC1)))
04900
00100 (DFUNC (INITZ X)
00200 (PROG NIL (SLOTPUSH (LIST X)) (OUTPUSH (Q ((QUOTE NIL))))))
00300
00400 (DFUNC (KILLPDL) (RESTORE NIL))
00500
00600 (DFUNC (LAMBDABIND VARS) (BINDVARS VARS T))
00700
00800 (DFUNC (LISTNILS NUMBER) (PROG (LIST)
00900 LOOP (COND ((ZEROP NUMBER) (RETURN LIST)))
01000 (SETQ LIST (CONS NIL LIST))
01100 (SETQ NUMBER (SUB1 NUMBER))
01200 (GO LOOP)))
01300
01400 (DFUNC (LOADARG ACNO VAR)
01500 (PROG (DATAORG OLDACC DATACONT DAC DOD)
01600 (REMOVE VAR)
01700 (SETQ DATAORG (ILOC1 VAR ACNO))
01800 (SETQ OLDACC (SLOTCONT ACNO))
01900 (SETQ DATACONT (COND ((NUMBERP DATAORG) (SLOTCONT DATAORG))))
02000 (SETQ DAC (DVP OLDACC))
02100 (SETQ DOD (DVP DATACONT))
02200 (COND ((EQ ACNO DATAORG) (COND (DAC (CPUSH ACNO))) (RETURN NIL)))
02300 (COND ((AND (EQ DATAORG 0) (NOT DOD) (NOT DAC) (GREATERP PDLDEPTH MINDEPTH)) (GO POP)))
02400 (COND ((AND (NOT DOD) OLDACC (NUMBERP DATAORG) (LESSP DATAORG ACNO))
02500 (GO EXCH)))
02600 (COND ((NOT DAC) (GO FREE)))
02700 (GO PUSH)
02800 EXCH (SETSLOT DATAORG OLDACC)
02900 (SETSLOT ACNO DATACONT)
03000 (OUT1 (QUOTE EXCH) ACNO DATAORG)
03100 (RETURN NIL)
03200 PUSH (CPUSH ACNO)
03300 (SETQ DATAORG (LOC VAR))
03400 FREE (COND ((NOT (NUMBERP DATAORG)) (GO MOVE)))
03500 (SETSLOT ACNO (COND ((NULL (CDR DATACONT))
03600 (CONS (CAR DATACONT) (QUOTE DUP)))
03700 (T DATACONT)))
03800 (OUTMOVE ACNO DATAORG)
03900 (RETURN NIL)
04000 POP (SETSLOT ACNO DATACONT)
04100 (OUTPOP ACNO)
04200 (RETURN NIL)
04300 MOVE (SETSLOT ACNO (COND ((EQ (CAAR DATAORG) (QUOTE QUOTE)) (CAR DATAORG))
04400 (T (LIST (CAR VAR)))))
04500 (OUTMOVE ACNO DATAORG)
04600 (RETURN NIL))))
04700
00100 (DFUNC (LOADCARCDR ITEM AC)
00200 (PROG (ARG PATH ORIG)
00300 (COND ((EQ (ILOC1 (SETQ ARG (CDDR ITEM)) AC) AC) (REMOVE ARG)))
00400 (SETQ PATH (CSTEP (CADR ITEM) AC ARG))
00500 (COND ((NULL (CDR PATH))
00600 (SETQ VARLIST
00700 (CONS (CONS (CAR (CAR PATH)) (CAR ITEM))
00800 VARLIST))
00900 (REMOVE ARG)
01000 (RETURN (LOC (CAR PATH)))))
01100 (SETQ PATH (REVERSE PATH))
01200 (CPUSH AC)
01300 (SETQ ORIG (LOC (CAR PATH)))
01400 (SETQ PATH (CDR PATH))
01500 (REMOVE ARG)
01600 L1 (COND ((NULL PATH) (GO RET)))
01700 (COND ((NULL (CDR PATH)) (GO L2)))
01800 (COND ((AND (EQ AC VALUEAC) (EQ ORIG VALUEAC))
01900 (OUTCALL 1 (READLIST (CONS (QUOTE C)
02000 (REVERSE (CONS (Q R)
02100 PATH)))))
02200 (GO RET)))
02300 L2 (OUT1 (CADR (ASSOC (CAR PATH) (Q ((A HLRZ@) (D HRRZ@)))))
02400 AC
02500 ORIG)
02600 (SETQ PATH (CDR PATH))
02700 (SETQ ORIG AC)
02800 (GO L1)
02900 RET (SETSLOT AC (LIST (CAR ITEM)))
03000 (RETURN AC)))
03100
03200 (DFUNC (LOADCOMP XPR AC) (LOADARG AC (COMP XPR AC)))
03300
03400 (DFUNC (LOADSUBRARGS ARGS) (PROG (ARGNO)
03500 (SETQ ARGNO (LENGTH ARGS))
03600 LOOP (COND ((NULL ARGS) (RETURN NIL)))
03700 (LOADARG ARGNO (CAR ARGS))
03800 (SETQ ARGS (CDR ARGS))
03900 (SETQ ARGNO (SUB1 ARGNO))
04000 (GO LOOP)))
04100
04200 (DFUNC (LOC X) (ILOC1 X NIL))
04300
00100 (DFUNC (NONSPECVARS VRS) (PROG (ANS)
00200 LOOP (COND ((NULL VRS) (RETURN ANS))
00300 ((SPECVARP (CAR VRS)))
00400 (T (SETQ ANS (CONS (CAR VRS) ANS))))
00500 (SETQ VRS (CDR VRS))
00600 (GO LOOP)))
00700
00800 (DFUNC (OUT1 OP AC AD) (OUTINST (TRANSOUT OP AC AD)))
00900
01000 (DFUNC (OUTCALL NUM FUN) (OUTFUNCALL (Q CALL) NUM FUN))
01100
01200 (DFUNC (OUTCALLF AC AD) (OUT1 (Q CALLF@) AC AD))
01300
01400 (DFUNC (OUTCJMP FLAG AC ADRESS)
01500 (OUTJMP (COND (FLAG (Q JUMPN)) (T (Q JUMPE))) AC ADRESS))
01600
01700 (DFUNC (OUTENDTAG X) (COND ((USEDTAGP X) (CLEARITALL) (RST X) (OUTTAG X))))
01800
01900 (DFUNC (OUTFUNCALL TYPE NUM FUN)
02000 (OUTINST (LIST TYPE NUM (LIST (Q E) FUN))))
02100
02200 (DFUNC (OUTGOTAB X)
02300 (PROG (ETAG)
02400 (SETQ ETAG (GENTAG))
02500 (PUTPROP ETAG (TOPCOPY REGPDL) (Q LEVEL))
02600 (COND ((NOT (EQ (CAAR LASTOUT) (Q JRST)))
02700 (OUTJRST ETAG)))
02800 (OUTTAG (CAR X))
02900 LOOP (SETQ X (CDR X))
03000 (COND ((NULL X)
03100 (OUTINST (Q (PUSHJ P *UDT)))
03200 (OUTTAG ETAG)
03300 (RETURN NIL)))
03400 (OUTINST (LIST (QUOTE CAIN) GOTABAC (LIST (QUOTE QUOTE) (CAAR X))))
03500 (OUTJRST (CDAR X))
03600 (GO LOOP)))
03700
03800 (DFUNC (OUTJCALL NUM FUN) (OUTFUNCALL (Q JCALL) NUM FUN))
00100 (DFUNC (OUTJMP OP AC ADR) (PROG NIL
00200 (SAVEACS)
00300 (CLEAR1BOTH)
00400 (RST ADR)
00500 (PUTPROP ADR T (QUOTE USED))
00600 (OUTINST (LIST OP AC ADR)))))
00700
00800 (DFUNC (OUTJRST ADR) (OUTJMP (Q JRST) 0 ADR))
00900
01000 (DFUNC (OUTMOVE AC MEM)
01100 (COND ((EQ AC MEM) (BARF MOVEXX-OUTMOVE)) (T (OUT1 (Q MOVE) AC MEM))))
01200
01300 (DFUNC (OUTMOVEM AC MEM) (OUT1 (Q MOVEM) AC MEM))
01400
01500 (DFUNC (OUTPOP L) (PROG2 (SLOTPOP) (OUT1 (QUOTE POP) PDLAC L)))
01600
01700 (DFUNC (OUTPUSH L) (OUT1 (Q PUSH) PDLAC L))
01800
01900 (DFUNC (OUTPUT1 ST)
02000 (PROG (ADD)
02100 (COND ((ATOM ST) (GO PRINT)))
02200 (COND ((EQ (CAR ST) (Q LAP)) (GO PRINT)))
02300 (INCR CODESIZE)
02400 (SETQ ADD (CADDR ST))
02500 (COND ((AND (NOT (ATOM ADD)) (EQ (CAR ADD) (Q C)))
02600 (INCR CONSTSIZE)))
02700 PRINT(PRINTSTAT ST)))
02800
02900 (DFUNC (OUTSPECPUSH VAR)
03000 (PROG NIL (SLOTPUSH (CONS VAR P2CNT)) (OUTPUSH (LIST (QUOTE SPECIAL) VAR))))
03100
03200 (DFUNC (OUTSTAT ST)
03300 (PROG NIL
03400 (COND ((NULL LASTOUT) (GO SETIT)))
03500 (OUTPUT1 (CAR LASTOUT))
03600 (MAPC (FUNCTION PRINTEXPR) (CDR LASTOUT))
03700 SETIT(SETQ LASTOUT (CONS ST (LAPNOTES)))
03800 (RETURN NIL)))
03900
00100 (DFUNC (P2*EVAL XPR VALAC EFFECTS)
00200 (PROG (ARG TEM)
00300 (SETQ ARG (CADR XPR))
00400 (COND ((AND (EQ (CAR ARG) (Q CONS))
00500 (EQ (CAADR ARG) (Q QUOTE))
00600 (GETL (SETQ TEM (CADADR ARG))
00700 (Q (FEXPR FSUBR *FSUBR))))
00800 (GO NOCONS)))
00900 (RETURN (CALLSUBR XPR VALAC EFFECTS))
01000 NOCONS
01100 (LOADCOMP (CADDR ARG) VALUEAC)
01200 (PROTECTACS TEM)
01300 (OUTINST (LIST (Q CALL) 17 (LIST (Q E) TEM)))
01400 (RETURN (VALLOC VALUEAC))))
01500
01600 (DFUNC (P2ARG XPR VALAC EFFECTS)
01700 (PROG (ARG)
01800 (COND ((EQ FUNTYPE (Q *LSUBR)) (GO LSUBR)))
01900 (RETURN (CALLSUBR XPR VALAC EFFECTS))
02000 LSUBR(SETQ ARG (COMP (CADR XPR) VALAC))
02100 (COND ((EQ (CAR ARG) (QUOTE QUOTE))
02200 (CPUSH VALAC)
02300 (OUTMOVE VALAC (PDLINDEX))
02400 (REMOVE ARG)
02500 (OUTINST (LIST (QUOTE HRRZ) VALAC (CADR ARG) VALAC))
02600 (RETURN (VALLOC VALAC))))
02700 (LOADARG VALAC ARG)
02800 (OUT1 (QUOTE ADD) VALAC (PDLINDEX))
02900 (OUTINST (LIST (QUOTE HRRZ) VALAC (MINUS INUM0) VALAC))
03000 (RETURN (VALLOC VALAC))))
03100
03200 (DFUNC (P2BOOL XPR VALAC EFFECTS)
03300 (PROG (CTAG RSL G)
03400 (PUTPROP (SETQ G (GENTAG)) T (QUOTE SET))
03500 (BOOLEXPR XPR VALAC G T MINDEPTH)
03600 OUT (RETURN (BOOLVALUE VALAC EFFECTS G))))
03700
00100 (DFUNC (P2CARCDR XPR VALAC EFFECTS)
00200 (PROG (TEMP)
00300 (COND ((NOT (EQ (LENGTH (CDR XPR)) 1))
00400 (DATAERR ARGNOERR-P2CARCDR)))
00500 (COND (EFFECTS (RETURN (COMPE (CADR XPR) VALAC))))
00600 (SETQ XPR (CONS (SETQ TEMP (GENSYM))
00700 (CONS (CAR XPR) (COMP (CADR XPR) VALAC))))
00800 (SETQ CCLST (CONS XPR CCLST))
00900 (SETQ TEMP (LIST TEMP))
01000 (SETQ LDLST (CONS TEMP LDLST))
01100 (RETURN TEMP)))
01200
01300 (DFUNC (P2COND XPR VALAC EFFECTS)
01400 (PROG (CTAG RSL SETQVARS VARLOC)
01500 (SETQ SETQVARS (CADR XPR))
01600 LOOP (COND ((NULL SETQVARS) (GO CC2)))
01700 (COND ((ASSOC (CAR SETQVARS) LDLST) (GO CC3)))
01800 ELOOP(DOCDR SETQVARS)
01900 (GO LOOP)
02000 CC2 (CLEAR1)
02100 (P2COND1 (CDDR XPR) VALAC EFFECTS MINDEPTH)
02200 (SETQ P2CNT (PLUS P2CNT 2))
02300 (RETURN (COND (EFFECTS NIL) (T (VALLOC VALAC))))
02400 CC3 (SETQ VARLOC (LOC (CONS (CAR SETQVARS) P2CNT)))
02500 (COND ((NOT (NUMBERP VARLOC)) (GO CC4)))
02600 (COND ((NOT (DVP (SLOTCONT VARLOC)))
02700 (SETSLOT VARLOC (CONS (CAR SETQVARS) P2CNT))
02800 (GO LOOP)))
02900 CC4 (SLOTPUSH (CONS (CAR SETQVARS) P2CNT))
03000 (OUTPUSH VARLOC)
03100 (GO ELOOP)))
03200
00100 (DFUNC (P2COND1 EXP VALAC EFFECTS MINDEPTH)
00200 (PROG (CONDEXIT PAIREXIT H1 H2 RETNIL IRSSL ACNIL PAIR ATAG REST AC)
00300 (SETQ AC (COND ((NULL VALAC) (FREEAC)) (T VALAC)))
00400 (SETQ CONDEXIT (GENTAG))
00500 (SETQ IRSSL (TOPCOPY REGPDL))
00600 (SETQ MINDEPTH PDLDEPTH)
00700 (PUTPROP CONDEXIT IRSSL (QUOTE LEVEL))
00800 LOOP (SETQ RSL NIL)
00900 (COND ((NULL EXP) (COND (RETNIL (LOADARG AC (Q (QUOTE NIL)))))
01000 (OUTENDTAG CONDEXIT)
01100 (COND ((USEDTAGP PAIREXIT) (CLEARITALL)))
01200 (RESTORE IRSSL)
01300 (RETURN NIL)))
01400 (SETQ PAIR (CAR EXP))
01500 (COND ((NULL (CDR PAIR))
01600 (LOADCOMP (CAR PAIR) AC)
01700 (COND ((NOT (NULL (CDR EXP)))
01800 (OUTCJMP T AC CONDEXIT))
01900 (T (RESTORE IRSSL)))
02000 (GO NONIL)))
02100 (COND ((AND (EQUAL (CDR PAIR) (QUOTE ((QUOTE NIL))))
02200 (EQ (CAAR PAIR) (QUOTE NULL))
02300 (OR (ATOM (CADAR PAIR))
02400 (NOT (HASPROP (CAADAR PAIR) (Q BOOL)))))
02500 (LOADCOMP (CADAR PAIR) AC)
02600 (OUTCJMP NIL AC CONDEXIT)
02700 (SETQ RETNIL T)
02800 (GO ELOOP)))
02900 (COND ((OR LDLST (NOT (NULL (CDDR PAIR)))) (GO L2)))
03000 (COND ((AND (EQ (CAADR PAIR) (QUOTE GO))
03100 (ATOM (SETQ ATAG (CADADR PAIR))))
03200 (BOOLEXPR (CAR PAIR) AC (EQUIVTAG ATAG) T MINDEPTH)
03300 (GO NONIL)))
03400 (COND ((EQUAL (CADR PAIR) (QUOTE (RETURN (QUOTE NIL))))
03500 (BOOLEXPR (CAR PAIR) AC EXITN T MINDEPTH)
03600 (GO NONIL)))
03700 L2 (SETQ PAIREXIT (SETQ CTAG (GENTAG)))
03800 (PUTPROP PAIREXIT IRSSL (QUOTE LEVEL))
03900 (SETQ RSL NIL)
04000 (BOOLEXPR (CAR PAIR) AC PAIREXIT NIL MINDEPTH)
04100 (SETQ H2 (COND ((NOT (ATOM RSL)) RSL)
04200 (T (LIST (TOPCOPY ARGACS)
04300 (TOPCOPY REGPDL)
04400 PDLDEPTH))))
04500 (SETQ H1 (LIST (TOPCOPY SPLDLST) (TOPCOPY CCLST)))
04600 (SETQ REST (CDR PAIR))
04700 LP1 (COND ((NULL (CDR REST)) (GO L1)))
04800 (COMPE (CAR REST) AC)
04900 (SETQ REST (CDR REST))
05000 (GO LP1)
05100 L1 (COND (EFFECTS (COMPE (CAR REST) AC))
05200 (T (LOADCOMP (CAR REST) AC)))
05300 (SAVEACS)
05400 (SETQ SPLDLST (CAR H1))
05500 (SETQ CCLST (CADR H1))
05600 (SETQ H1 ARGACS)
05700 (SETQ ARGACS (CAR H2))
05800 (SETQ ACNIL (EQUAL (SLOTCONT AC) (Q (QUOTE NIL))))
05900 (SETQ ARGACS H1)
06000 (SETQ RETNIL NIL)
06100 (COND ((NOT (MEMQ (CAAR REST) (Q (GO RETURN))))
06200 (COND ((OR (NOT (NULL (CDR EXP)))
06300 (AND (NOT EFFECTS)
06400 (NOT ACNIL)
06500 (SETQ RETNIL (USEDTAGP PAIREXIT))))
06600 (OUTJRST CONDEXIT))
06700 (T (RESTORE IRSSL)))))
06800 (SETQ ARGACS (CAR H2))
06900 (SETQ REGPDL (CADR H2))
07000 (SETQ PDLDEPTH (CADDR H2))
07100 (OUTTAG PAIREXIT)
07200 (GO ELOOP)
07300 NONIL(SETQ RETNIL NIL)
07400 ELOOP(SETQ EXP (CDR EXP))
07500 (GO LOOP)))
07600
00100 (DFUNC (P2ELSE XPR VALAC EFFECTS) (BARF SOMETHINGELSE-P2ELSE))
00200
00300 (DFUNC (P2EQ XPR VALAC EFFECTS)
00400 (PROG NIL
00500 (COND (EFFECTS (COMPE (CADR XPR) VALAC)
00600 (COMPE (CADDR XPR) VALAC)
00700 (RETURN NIL)))
00800 (BOOLEQ1 (CDR XPR) VALAC NIL NIL)
00900 (RETURN (BOOLVALUE VALAC EFFECTS NIL))))
01000
01100 (DFUNC (P2GO XPR VALAC EFFECTS)
01200 (PROG (TAG)
01300 (SETQ TAG (CADR XPR))
01400 (SAVEACS)
01500 (CLRPVARS)
01600 (COND ((ATOM TAG) (OUTJRST (EQUIVTAG TAG)))
01700 (T (LOADARG GOTABAC (COMP TAG VALAC)) (OUTJRST VGO)))
01800 (RETURN (VALLOC VALUEAC))))
00100 (DFUNC (P2LAM XPR VALAC EFFECTS)
00200 (PROG (LAMXPR LAMARGS SF LAMVARS TL ACL TEM)
00300 (SETQ LAMXPR (CAR XPR))
00400 (SETQ LAMARGS (REVERSE (COMPARGS (CDR XPR))))
00500 (SETQ LAMVARS (CADR LAMXPR))
00600 A (COND ((NULL LAMVARS) (GO B)))
00700 (SETQ TL (ILOC1 (CAR LAMARGS) (FREEAC)))
00800 (REMOVE (CAR LAMARGS))
00900 (COND ((SPECVARP (CAR LAMVARS))
01000 (SETQ SF T)
01100 (COND ((OR (NOT (NUMBERP TL)) (LESSP TL 1))
01200 (LOADARG (SETQ TL (FREEAC)) (CAR LAMARGS)))))
01300 ((OR (NOT (NUMBERP TL))
01400 (DVP (SETQ TEM (SLOTCONT TL))))
01500 (SLOTPUSH TEM)
01600 (COND ((NULL (CDR TEM))
01700 (SETSLOT TL (CONS (CAR TEM) (Q DUP)))))
01800 (OUTPUSH TL)
01900 (SETQ TL 0)))
02000 (SETSLOT TL (CONS (CAR LAMVARS) (QUOTE TAKEN)))
02100 (SETQ ACL (CONS TL ACL))
02200 (SETQ LAMARGS (CDR LAMARGS))
02300 (SETQ LAMVARS (CDR LAMVARS))
02400 (GO A)
02500 B (COND (SF (OUTINST (QUOTE (JSP 6 SPECBIND)))) (T (GO D)))
02600 (SETQ LAMVARS (CADR LAMXPR))
02700 C (COND ((NULL LAMVARS) (GO D))
02800 ((SPECVARP (CAR LAMVARS))
02900 (P2LAM1 LAMVARS ARGACS)
03000 (P2LAM1 LAMVARS REGPDL)
03100 (OUTINST (LIST 0
03200 (ILOC (CONS (CAR LAMVARS) P2CNT))
03300 (LIST (QUOTE SPECIAL) (CAR LAMVARS))))))
03400 (SETQ LAMVARS (CDR LAMVARS))
03500 (GO C)
03600 D (COND ((NULL ACL) (GO E)))
03700 (REPLACECDR (SLOTCONT (CAR ACL)) NIL)
03800 (SETQ ACL (CDR ACL))
03900 (GO D)
04000 E (SETQ LAMVARS (COMP (CADDR LAMXPR) VALAC))
04100 (COND (SF (OUTINST (QUOTE (PUSHJ P SPECSTR)))))
04200 (SETQ P2CNT (ADD1 P2CNT))
04300 (RETURN LAMVARS)))
04400
04500 (DFUNC (P2LAM1 X Y) (PROG NIL
04600 A (COND ((NULL Y) (RETURN NIL))
04700 ((NULL (CAR Y)))
04800 ((AND (EQ (CAAR Y) (CAR X)) (NULL (CDAR Y)))
04900 (REPLACECAR Y NIL)))
05000 (SETQ Y (CDR Y))
05100 (GO A)))
05200
00100 (DFUNC (P2PROG XPR VALAC EFFECTS)
00200 (PROG (PSFLG)
00300 (SETQ PSFLG (PROGBIND (CADDR XPR)))
00400 (SETQ PRGSPFLG NIL)
00500 (CLEAR1)
00600 (P2PROG1 XPR VALAC EFFECTS MINDEPTH)
00700 (COND (PSFLG (OUTINST (Q (PUSHJ P SPECSTR)))))
00800 (RETURN (VALLOC VALAC))))
00900
01000 (DFUNC (P2PROG1 XPR VALAC EFFECTS MINDEPTH)
01100 (PROG (GOLIST EXIT EXITN PVR PRSSL PROGSW VGO)
01200 (INCR P2CNT)
01300 (SETQ PROGSW T)
01400 (SETQ PVR VALAC)
01500 (SETQ EXIT (GENTAG))
01600 (SETQ EXITN (GENTAG))
01700 (SETQ VGO (GENTAG))
01800 (SETQ GOLIST (CONS (CONS NIL EXIT)
01900 (CONS (CONS NIL EXITN)
02000 (CONS (CONS NIL VGO) (CADR XPR)))))
02100 (SETQ PROGVARS (NONSPECVARS (CADDR XPR)))
02200 (SETQ XPR (CDDDR XPR))
02300 LOOP (COND ((NULL XPR) (GO EXITN)))
02400 (INCR P2CNT)
02500 (COND ((NOT PROGSW) (RESTORE PRSSL)))
02600 (COND ((TAGP (CAR XPR)) (PROGTAG (CAR XPR)))
02700 ((AND (NULL (CDR XPR)) (EQ (CAAR XPR) (QUOTE RETURN)))
02800 (COND ((EQUAL (CDAR XPR) (Q ((QUOTE NIL)))) (GO EXITN))
02900 (T (LOADARG PVR (COMP (CADAR XPR) VALAC))
03000 (COND ((USEDTAGP EXITN) (OUTJRST EXIT)
03100 (GO EXITN))
03200 (T (GO EXIT))))))
03300 (T (COMPE (CAR XPR) VALAC)))
03400 (SETQ XPR (CDR XPR))
03500 (GO LOOP)
03600 EXITN(OUTENDTAG EXITN)
03700 (COND ((NOT (EQ (CAAR LASTOUT) (QUOTE JRST)))
03800 (LOADARG PVR (Q (QUOTE NIL)))))
03900 EXIT (OUTENDTAG EXIT)
04000 (SETQ P2CNT (PLUS 2 P2CNT))
04100 (COND ((USEDTAGP VGO)
04200 (OUTGOTAB (CONS VGO (CDDDR GOLIST)))))
04300 (RETURN NIL)))
04400
00100 (DFUNC (P2PROG2 XPR VALAC EFFECTS)
00200 (PROG (ARGS ARG2)
00300 (SETQ ARGS (CDR XPR))
00400 (COND ((LESSP (LENGTH ARGS) 2) (BARF TOFEWARGS-P2PROG2)))
00500 (COMPE (CAR ARGS) VALAC)
00600 (SETQ ARG2 (COND ((NOT EFFECTS) (COMP (CADR ARGS) VALAC))
00700 (T (COMPE (CADR ARGS) VALAC))))
00800 (SETQ ARGS (CDDR ARGS))
00900 LOOP (COND ((NULL ARGS) (RETURN ARG2)))
01000 (COMPE (CAR ARGS) VALAC)
01100 (SETQ ARGS (CDR ARGS))
01200 (GO LOOP)))
01300
01400 (DFUNC (P2QUOTE XPR VALAC EFFECTS) XPR)
01500
01600 (DFUNC (P2RETURN XPR VALAC EFFECTS)
01700 (PROG (VAL)
01800 (SETQ VAL (CADR XPR))
01900 (SAVEACS)
02000 (CLRPVARS)
02100 (COND ((EQUAL VAL (QUOTE (QUOTE NIL))) (OUTJRST EXITN))
02200 (T (LOADARG PVR (COMP VAL VALAC)) (OUTJRST EXIT)))
02300 (RETURN (COND (EFFECTS NIL) ((VALLOC VALAC))))))
02400
00100 (DFUNC (P2RPLAC XPR VALAC EFFECTS)
00200 (PROG (ARG1 ARG2)
00300 (SETQ ARG1 (COMP (CADR XPR) (FREEAC)))
00400 (SETQ ARG2 (COMP (CADDR XPR) (FREEAC)))
00500 (ILOC1 ARG1 VALAC)
00600 (LOC ARG2)
00700 (REMOVS ARG1)
00800 (REMOVS ARG2)
00900 (CLEAR2BOTH)
01000 (COND ((EQUAL ARG2 (QUOTE (QUOTE NIL)))
01100 (OUT1 (CADR (ASSOC (CAR XPR)
01200 (Q ((RPLACA HRRZS@) (RPLACD HLLZS@)))))
01300 0
01400 (LOC ARG1)))
01500 (T (OUT1 (CADR (ASSOC (CAR XPR)
01600 (Q ((RPLACA HRLM@) (RPLACD HRRM@)))))
01700 (PUTINAC ARG2 (FREEAC))
01800 (LOC ARG1))))
01900 (REMOVE ARG1)
02000 (REMOVE ARG2)
02100 (RETURN ARG1)))
02200
02300 (DFUNC (P2SETARG XPR VALAC EFFECTS)
02400 (PROG (TEM)
02500 (LOC (SETQ TEM (COMP (CADDR XPR))))
02600 (COND ((EQ (CAADR XPR) (Q QUOTE))
02700 (OUT1 (Q MOVE) 2 (PDLINDEX))
02800 (RETURN (OUTINST (LIST (Q HRRM)
02900 (PUTINAC TEM VALAC)
03000 (CADADR XPR)
03100 2)))))
03200 (LOADARG 2 (COMP (CADR XPR)))
03300 (CLRARGACS)
03400 (OUT1 (Q ADD) 2 (PDLINDEX))
03500 (OUTINST (LIST (Q HRRM) (PUTINAC TEM VALAC) (MINUS INUM0) 2))))
03600
00100 (DFUNC (P2SETQ XPR VALAC EFFECTS)
00200 (PROG (VARLOC VALUELOC HOME VAR VAL TEM AC)
00300 (SETQ AC (COND ((NULL VALAC) (FREEAC)) (T VALAC)))
00400 (SETQ VAR (CAR (CDR XPR)))
00500 (SETQ VAL (COMP (CADR (CDR XPR)) AC))
00600 (ILOC1 VAL AC)
00700 (COND ((ASSOC VAR SPLDLST) (OUTSPECPUSH VAR) (REMSPVAR VAR)))
00800 (REMOVE VAL)
00900 (FREEZE VAR)
01000 (SETQ VALUELOC (LOC VAL))
01100 (SETQ HOME (COND ((SPECVARP VAR) T)
01200 ((NOT (ILOC (SETQ VARLOC (CONS VAR P2CNT)))) NIL)
01300 (T (NOT (DVP (SLOTCONT (LOC VARLOC)))))))
01400 (SETQ P2CNT (ADD1 P2CNT))
01500 (COND ((AND EFFECTS (NOT HOME))
01600 (COND ((AND (NUMBERP VALUELOC)
01700 (NOT (DVP (SLOTCONT VALUELOC))))
01800 (SETSLOT VALUELOC (LIST VAR))
01900 (GO EXIT))
02000 (T (SLOTPUSH (LIST VAR))
02100 (OUTPUSH VALUELOC)
02200 (GO EXIT)))))
02300 (COND ((AND HOME (EQUAL VAL (QUOTE (QUOTE NIL))))
02400 (SETQ TEM T)
02500 (OUT1 (COND ((OR EFFECTS (DVP (SLOTCONT AC)))
02600 (SETQ TEM NIL)
02700 (QUOTE CLEARM))
02800 (T (QUOTE CLEARB)))
02900 AC
03000 (SETQ VAL (COND ((SPECVARP VAR)
03100 (LIST (QUOTE SPECIAL) VAR))
03200 (T (ILOC (CONS VAR (SUB1 P2CNT)))))))
03300 (COND ((NUMBERP VAL) (SETSLOT VAL (LIST VAR))))
03400 (COND (TEM (SETSLOT AC (CONS VAR
03500 (COND ((NUMBERP VAL) (Q DUP))
03600 (T NIL))))))
03700 (GO EXIT)))
03800 (COND ((OR (NOT (NUMBERP VALUELOC))
03900 (LESSP VALUELOC 0)
04000 (DVP (SLOTCONT VALUELOC)))
04100 (LOADARG AC VAL)
04200 (SETQ VALUELOC AC)))
04300 (SETSLOT VALUELOC (LIST VAR))
04400 (COND ((SPECVARP VAR)
04500 (COND ((ZEROP VALUELOC) (OUTPOP (LIST (QUOTE SPECIAL) VAR)))
04600 (T (OUTMOVEM VALUELOC (LIST (QUOTE SPECIAL) VAR))))))
04700 EXIT (RETURN (COMP VAR AC))))
04800
00100 (DFUNC (P2STORE XPR VALAC EFFECTS)
00200 (PROG (TEM)
00300 (LOC (SETQ TEM (COMP (CADDR XPR) VALAC)))
00400 (COMPE (CADR XPR) VALAC)
00500 (LOADARG ARRAYAC TEM)
00600 (OUTINST (Q (PUSHJ P NSTR)))
00700 (RETURN TEM)))
00800
00900 (DFUNC (PASS2 X)
01000 (PROG (ARGACS REGPDL
01100 PDLDEPTH
01200 MINDEPTH
01300 LDLST
01400 SPECFLAG
01500 PRGSPFLG
01600 PROGVARS
01700 SPLDLST
01800 CCLST
01900 PROGSW
02000 GOLIST
02100 LASTOUT
02200 VARLIST)
02300 (SETQ P2CNT 1)
02400 (SETQ ARGACS (LISTNILS NACS))
02500 (SETQ REGPDL NIL)
02600 (SETQ PDLDEPTH (LENGTH REGPDL))
02700 (SETQ MINDEPTH PDLDEPTH)
02800 (OUTPSOP (LIST (Q LAP) FUNNAME FUNFLAG))
02900 (COND ((EQ FUNTYPE (Q *LSUBR)) (OUTINST (QUOTE (JSP 3 *LCALL))))
03000 ((AND (EQ FUNTYPE (QUOTE *FSUBR)) (CDADR X))
03100 (OUTINST (QUOTE (PUSHJ P *AMAKE)))))
03200 (SETQ SPECFLAG (LAMBDABIND (CADR X)))
03300 (COND ((NOT (EQ (CAADDR X) (QUOTE PROG))) (SETQ PRGSPFLG NIL)))
03400 (LOADCOMP (CADDR X) VALUEAC)
03500 (EXITBUM SPECFLAG)
03600 (OUTINST (OUTINST NIL))
03700 (COND (LDLST (BARF LDLSTLEFT-PASS2)))
03800 (RETURN NIL)))
03900
00100 (DFUNC (PROGBIND VARS) (BINDVARS VARS NIL))
00200
00300 (DFUNC (PROGTAG TAG) (PROG NIL
00400 (CLEAR2BOTH)
00500 (CLRARGACS)
00600 (CLRPVARS)
00700 (RESTORE PRSSL)
00800 (OUTTAG (EQUIVTAG TAG))))
00900
01000 (DFUNC (PROTECTACS X)
01100 (PROG (WHICHACS ACNO)
01200 (SETQ WHICHACS (ACEFFECTS X))
01300 (SETQ ACNO 0)
01400 LOOP (SETQ ACNO (ADD1 ACNO))
01500 (COND ((ZEROP WHICHACS) (RETURN NIL))
01600 ((NOT (ZEROP (BOOLE 1 1 WHICHACS))) (CLEARAC ACNO)))
01700 (SETQ WHICHACS (LSH WHICHACS -1))
01800 (GO LOOP)))
01900
02000 (DFUNC (PUTINAC X AC) (PROG (Z)
02100 (SETQ Z (LOC X))
02200 (COND ((NOT (ACNUMP Z)) (LOADARG (SETQ Z AC) X)))
02300 (REMOVE X)
02400 (CPUSH Z)
02500 (RETURN Z)))
02600
02700 (DFUNC (REMOVE DATA)
02800 (PROG NIL (REMLST DATA (Q LDLST)) (REMLST DATA (Q SPLDLST))))
02900
03000 (DFUNC (REMLST DATA LST)
03100 (PROG (TEM)
03200 (SETQ TEM (GETPROP LST (Q VALUE)))
03300 LOOP (COND ((NULL (CDR TEM)) (RETURN NIL)))
03400 (COND ((EQUAL (CADR TEM) DATA) (REPLACECDR TEM (CDDR TEM)))
03500 (T (SETQ TEM (CDR TEM))))
03600 (GO LOOP)))
03700
03800 (DFUNC (REMOVS DATA) (REMLST DATA (Q SPLDLST)))
03900
04000 (DFUNC (REMSPVAR SPV)
04100 (PROG (SPL)
04200 (SETQ SPL (GETPROP (Q SPLDLST) (Q VALUE)))
04300 BACK (COND ((NULL (CDR SPL)) (RETURN NIL)))
04400 (COND ((EQ SPV (CAADR SPL)) (REPLACECDR SPL (CDDR SPL)))
04500 (T (SETQ SPL (CDR SPL))))
04600 (GO BACK)))
04700
00100 (DFUNC (RESTORE OLDPDL)
00200 (PROG (C V R TEM OLDDEPTH DEPTHDIF)
00300 (SETQ OLDDEPTH (LENGTH OLDPDL))
00400 (COND ((GREATERP OLDDEPTH PDLDEPTH) (PRINTMSG (LIST OLDPDL REGPDL))
00500 (BARF PDLTOOSHORT-RESTORE)))
00600 A1 (SETQ C 0)
00700 A (COND ((EQUAL OLDDEPTH PDLDEPTH) (RETURN (SHRINKPDL C)))
00800 ((DVP (SETQ R (CAR REGPDL))) (GO CPP)))
00900 (SETQ C (ADD1 C))
01000 (SLOTPOP)
01100 (GO A)
01200 CPP (SHRINKPDL C)
01300 CPP1 (SETQ V OLDPDL)
01400 (SETQ C 0)
01500 (SETQ DEPTHDIF (*DIF PDLDEPTH OLDDEPTH))
01600 CPP3 (COND ((NULL V) (SETSLOT (SETQ V (FREEAC)) R) (OUTPOP V) (GO A1))
01700 ((AND (CAR V)
01800 (EQ (CAAR V) (CAR R))
01900 (NOT (DVP (SLOTCONT (SETQ TEM
02000 (MINUS (PLUS C
02100 DEPTHDIF)))))))
02200 (GO CPP2)))
02300 (SETQ C (ADD1 C))
02400 (SETQ V (CDR V))
02500 (GO CPP3)
02600 CPP2 (SETSLOT TEM R)
02700 (OUTPOP TEM)
02800 (GO A1)))
02900
03000 (DFUNC (RSLSET X)
03100 (COND ((EQ X CTAG)
03200 (SETQ RSL (COND ((AND RSL (NOT (AND (EQUAL (CAR RSL) ARGACS)
03300 (EQUAL (CADR RSL) REGPDL))))
03400 (QUOTE LOSE))
03500 (T (LIST (TOPCOPY ARGACS)
03600 (TOPCOPY REGPDL)
03700 PDLDEPTH)))))))
03800
03900 (DFUNC (RST TAG) (COND ((NULL TAG) NIL)
04000 ((ASSOCR TAG GOLIST) (RESTORE PRSSL))
04100 ((REMPROP TAG (QUOTE SET))
04200 (SAVEACS)
04300 (PUTPROP TAG (TOPCOPY REGPDL) (QUOTE LEVEL))
04400 (SETQ MINDEPTH PDLDEPTH))
04500 ((SETQ TAG (SEEKPROP TAG (Q LEVEL))) (RESTORE (PROPVAL TAG)))
04600 (T (BARF NIL-RST))))
04700
00100 (DFUNC (SAVEACS) (PROG (K)
00200 (SETQ K 0)
00300 LOOP (COND ((EQ K NACS) (RETURN NIL)))
00400 (CPUSH (SETQ K (ADD1 K)))
00500 (GO LOOP)))
00600
00700 (DFUNC (SETSLOT X Y) (REPLACECAR (GETSLOT X) Y))
00800
00900 (DFUNC (SHRINKPDL C)
01000 (COND ((NOT (ZEROP C))
01100 (OUTINST (LIST (QUOTE SUB) PDLAC (GENCONST 0 0 C C 0))))))
01200
01300 (DFUNC (SIDEEFFECTS FUN) (NOT (HASPROP FUN (QUOTE ACS))))
01400
01500 (DFUNC (SLOTCONT X) (CAR (GETSLOT X)))
01600
01700 (DFUNC (SLOTLIST) (APPEND ARGACS REGPDL))
01800
01900 (DFUNC (SLOTPOP)
02000 (PROG NIL (SETQ PDLDEPTH (SUB1 PDLDEPTH)) (SETQ REGPDL (CDR REGPDL))))
02100
02200 (DFUNC (SLOTPUSH SC) (PROG NIL
02300 (SETQ PDLDEPTH (ADD1 PDLDEPTH))
02400 (SETQ REGPDL (CONS SC REGPDL))))
02500
02600 (DFUNC (SPECVARP VAR) (MEMBER VAR SPECVARS))
02700
00100 (DFUNC (TRANSOUT OP AC AD)
00200 (PROG (TEM IND)
00300 (COND ((OR (ATOM AD) (ATOM (CAR AD))) (GO DONE)))
00400 (SETQ AD (CAR AD))
00500 (COND ((SETQ TEM (SEEKPROP OP (Q IMMED)))
00600 (SETQ OP (PROPVAL TEM))
00700 (GO DONE)))
00800 (SETQ AD (GENCONST 0 0 AD 0 0))
00900 DONE (SETQ IND
01000 (COND ((OR (NOT (NUMBERP AD)) (GREATERP AD 0)) NIL)
01100 (T (LIST PDLAC))))
01200 (RETURN (MCONS OP AC AD IND))))
01300
01400 (DFUNC (USEDTAGP TAG) (HASPROP TAG (Q USED)))
01500
01600 (DFUNC (VALLOC LOCATION)
01700 (PROG (VAR GVAL)
01800 (COND ((NULL LOCATION) (BARF NULLLOC-VALLOC)))
01900 (SETQ GVAL (GENVAL))
02000 (SETQ VAR (CAR (SETSLOT LOCATION (LIST GVAL))))
02100 (SETQ LDLST (CONS VAR LDLST))
02200 (RETURN VAR)))
02300
00100 (MAPDEF PASS2
00200 ((EXPR CALLSUBR) (SUBR CALLSUBR)
00300 (*SUBR CALLSUBR)
00400 (*UNDEF CALLSUBR)
00500 (LSUBR CALLLSUBR)
00600 (*LSUBR CALLLSUBR)
00700 (FEXPR CALLFSUBR)
00800 (FSUBR CALLFSUBR)
00900 (*FSUBR CALLFSUBR)
01000 (FUNVAR CALLFUNARGS)
01100 (CARCDRPROP P2CARCDR)
01200 (P2 DOP2)))
01300
01400 (MAPDEF P2
01500 ((AND P2BOOL) (ARG P2ARG)
01600 (*EVAL P2*EVAL)
01700 (COND P2COND)
01800 (EQ P2EQ)
01900 (GO P2GO)
02000 (NULL P2BOOL)
02100 (OR P2BOOL)
02200 (QUOTE P2QUOTE)
02300 (PROG P2PROG)
02400 (PROG2 P2PROG2)
02500 (RETURN P2RETURN)
02600 (RPLACA P2RPLAC)
02700 (RPLACD P2RPLAC)
02800 (SETARG P2SETARG)
02900 (SETQ P2SETQ)
03000 (STORE P2STORE)))
03100
03200 (MAPDEF BOOL
03300 ((AND BOOLAND) (EQ BOOLEQ)
03400 (NULL BOOLNULL)
03500 (OR BOOLOR)
03600 (QUOTE BOOLQUOTE)))
03700
00100 (SETQ CARCDRDEPTH 4)
00200
00300 (PROG (BASE COUNT LIMIT MIDDLE NAME)
00400 (SETQ BASE 2)
00500 (SETQ LIMIT (SUB1 (LSH 1 (ADD1 CARCDRDEPTH))))
00600 (SETQ COUNT (LSH 1 1))
00700 LOOP (COND ((GREATERP COUNT LIMIT) (RETURN NIL)))
00800 (SETQ MIDDLE
00900 (SUBST (QUOTE A) 0 (SUBST (QUOTE D) 1 (CDR (EXPLODE COUNT)))))
01000 (SETQ NAME (READLIST (APPEND (QUOTE (C)) MIDDLE (QUOTE (R)))))
01100 (PUTPROP NAME
01200 (CONS (CAR MIDDLE)
01300 (COND ((CDR MIDDLE)
01400 (READLIST (APPEND (QUOTE (C))
01500 (CDR MIDDLE)
01600 (QUOTE (R)))))))
01700 (QUOTE CARCDRPROP))
01800 (SETQ COUNT (ADD1 COUNT))
01900 (GO LOOP))
02000
02100 (MAPDEF ACS
02200 ((*APPEND 37)
02300 (ATOM 1)
02400 (CONS 3)
02500 (GENSYM 7)
02600 (GET 1)
02700 (LAST 3)
02800 (LENGTH 7)
02900 (MEMBER 37)
03000 (NCONS 3)
03100 (XCONS 3)))
03200
00100 (MAPDEF COMMU
00200 ((CONS XCONS) (EQUAL EQUAL)
00300 (*GREAT *LESS)
00400 (*LESS *GREAT)
00500 (*PLUS *PLUS)
00600 (*TIMES *TIMES)))
00700
00800 (MAPDEF IMMED
00900 ((CAME CAIE) (CAMN CAIN)
01000 (HLLZS@ HLLZS)
01100 (HLRZ@ HLRZ)
01200 (HRLM@ HRLM)
01300 (HRRM@ HRRM)
01400 (HRRZ@ HRRZ)
01500 (HRRZS@ HRRZS)
01600 (MOVE MOVEI)))
01700
01800 (SETQ NACS 5)
01900
02000 (SETQ VALUEAC 1)
02100
02200 (SETQ ALLACS (SUB1 (LSH 1 NACS)))
02300
02400 (SETQ FARGAC 1)
02500
02600 (SETQ GOTABAC 1)
02700
02800 (SETQ ARRAYAC 1)
02900
03000 (SETQ PDLAC (QUOTE P))
03100
03200 (SETQ INUM0 577777)
03300
03400 (ENDBLOCK PASS2)
03500
00100 (BEGINBLOCK DEBUG)
00200
00300 (DEFPROP BARF (LAMBDA (L) (BREAK (Q (*COMPILER ERROR*)) L)) FEXPR)
00400
00500 (DEFPROP DATAERR (LAMBDA (L) (BREAK (Q (*USER ERROR*)) L)) FEXPR)
00600
00700 (DFUNC (BREAK TYPE MESSAGE)
00800 (PROG NIL
00900 (INC NIL T)
01000 (OUTC NIL T)
01100 (CARRET)
01200 (LINEF)
01300 (PRINL (APPEND TYPE MESSAGE))
01400 LOOP (COND ((EQUAL (ERRSET (EVALREAD)) (Q (PROCEED)))
01500 (RETURN (Q DONE))))
01600 (GO LOOP)))
01700
01800 (DFUNC (EVALREAD) (PROG (EX)
01900 (CARRET)
02000 (SETQ EX (READ))
02100 (PRINC *SP)
02200 (RETURN (PRINC (EVAL EX)))))
02300
02400 (DFUNC (LAPNOTES) (COPY (MAPCAR (FUNCTION EVAL) TRACELIST)))
02500
02600 (DFUNC (P1SPY X) NIL)
02700
02800 (SETQ TRACELIST NIL)
02900
03000
03100 (ENDBLOCK DEBUG)
03200
00100 (BEGINBLOCK IO)
00200
00300 (DFUNC (CARRET) (COND ((NOT (EQ (CHRCT) (LINELENGTH NIL))) (LINEF))))
00400
00500 (DFUNC (FLATP X Y Z) (LESSP (FLATSIZE X) Z))
00600
00700 (DFUNC (FORMF)
00800 (PROG NIL (PRINC *FF) (SETQ LINCNT PAGEHEIGHT)))
00900
01000 (DFUNC (LINEF) (PROG (LINEL)
01100 (SETQ LINCNT (SUB1 LINCNT))
01200 (SETQ LINEL (LINELENGTH NIL))
01300 (LINELENGTH 1)
01400 (PRINC *SP)
01500 (LINELENGTH LINEL)
01600 (TERPRI)))
01700
01800 (DFUNC (PRINL L) (MAPC (FUNCTION PRINS) L))
01900
02000 (DFUNC (PRINS X) (PROG2 (PRIN1 X) (PRINC *SP)))
02100
02200 (DFUNC (PRINTEXPR XPR) (PROG2 (PRIN1 XPR) (PRINC *SP)))
02300
02400 (DFUNC (PRINTLAP CODE) (MAPC (FUNCTION PRINTSTAT) CODE))
02500
02600 (DFUNC (PRINTSTAT STAT)
02700 (PROG NIL
02800 (COND ((GREATERP (DIFFERENCE (LINELENGTH NIL) (CHRCT)) 7) (LINEF)))
02900 (COND ((NULL STAT) (GO WORD))
03000 ((ATOM STAT) (GO TAG))
03100 ((EQ (CAR STAT) (QUOTE LAP)) (GO TAG)))
03200 WORD (PRINC *TB)
03300 (PRINTEXPR STAT)
03400 (RETURN NIL)
03500 TAG (CARRET)
03600 (PRINTEXPR STAT)
03700 (RETURN NIL)))
03800
03900 (DFUNC (READLAP CALL)
04000 (PROG (STAT CODE)
04100 (SETQ CODE (LIST CALL))
04200 READ (SETQ STAT (ERRSET (READ)))
04300 (COND ((ATOM STAT) (BARF READERR-READLAP)))
04400 (SETQ CODE (CONS (CAR STAT) CODE))
04500 (COND ((NULL (CAR STAT)) (RETURN (REVERSE CODE))))
04600 (GO READ)))
04700
00100 (MAPCAR
00200 (FUNCTION
00300 (LAMBDA (PAIR) (PROG2 (SET (CAR PAIR) (INTERN (ASCII (CADR PAIR))))
00400 (CAR PAIR))))
00500 (QUOTE ((*SP 40) (*TB 11)
00600 (*CR 15)
00700 (*LF 12)
00800 (*VT 13)
00900 (*FF 14)
01000 (*CO 54)
01100 (*PT 56)
01200 (*LP 50)
01300 (*RP 51)
01400 (*SL 57)
01500 (*AM 33)
01600 (*AT 100)
01700 (*RO 177)
01800 (*COLON 72))))
01900
02000 (SETQ LINCNT 0)
02100
02200 (SETQ PAGEHEIGHT 74)
02300
02400 (SETQ PAGEWIDTH 120)
02500
02600 (ENDBLOCK IO)
00100 (BEGINBLOCK GENERAL)
00200
00300 (DFUNC (ADDTOLIST X Y) (COND ((MEMBER X Y) Y) (T (CONS X Y))))
00400
00500 (DFUNC (ASSOCR X Y)
00600 (PROG NIL
00700 LOOP (COND ((NULL Y) (RETURN NIL)) ((EQ X (CDAR Y)) (RETURN (CAR Y))))
00800 (SETQ Y (CDR Y))
00900 (GO LOOP)))
01000
01100 (DFUNC (CONSTANTP XPR) (OR (NUMBERP XPR) (MEMBER XPR (QUOTE (T NIL)))))
01200
01300 (DFUNC (COPY EX) (SUBST 0 0 EX))
01400
01500 (DFUNC (FSUBRP FUN) (GETL FUN (Q (FEXPR *FSUBR FSUBR))))
01600
01700 (DFUNC (GETGET ATOM PROP)
01800 (PROG (TEM PTAB)
01900 (SETQ PTAB (PROPTABLE ATOM))
02000 LOOP (COND ((NULL PTAB) (RETURN NIL)))
02100 (COND ((SETQ TEM (GETL (CAR PTAB) (LIST PROP)))
02200 (RETURN (LIST (CADR TEM)))))
02300 (SETQ PTAB (CDDR PTAB))
02400 (GO LOOP)))
02500
02600 (DFUNC (LSUBRP FUN) (GETL FUN (Q (LSUBR *LSUBR))))
02700
02800 (DFUNC (MAKESPECIAL VAR) (PUTPROP VAR T (Q SPECIAL)))
02900
03000 (DFUNC (MAKESYM IDENT NUMBER)
03100 (PROG (*NOPOINT)
03200 (SETQ *NOPOINT T)
03300 (RETURN (MAKNAM (APPEND (EXPLODE IDENT) (EXPLODE NUMBER))))))
03400
03500 (DFUNC (MAKEUNSPECIAL VAR) (REMPROP VAR (Q SPECIAL)))
03600
03700 (DFUNC (NTHCDR NUM EXP)
03800 (PROG NIL
03900 (COND ((MINUSP NUM) (BARF NEGNUM-NTHCDR)))
04000 LOOP (COND ((ZEROP NUM) (RETURN EXP)))
04100 (COND ((ATOM EXP) (BARF ATOM-NTHCDR)))
04200 (SETQ EXP (CDR EXP))
04300 (SETQ NUM (SUB1 NUM))
04400 (GO LOOP)))
04500
04600
04700 (DFUNC (SUBRP FUN) (GETL FUN (Q (EXPR SUBR ARRAY *SUBR *UNDEF))))
04800
04900 (DFUNC (TOPCOPY SXP) (APPEND SXP NIL))
05000
00100 (BEGINBLOCK PROPTABLE)
00200
00300 (DFUNC (INITPROP IDENT PROPNAM PROPVAL)
00400 (PUTPROP IDENT PROPVAL PROPNAM))
00500
00600 (DFUNC (SEEKPROP IDENT PROPNAM)
00700 (PROG (TEM)
00800 (SETQ TEM (GETL IDENT (LIST PROPNAM)))
00900 (COND ((NULL TEM) (RETURN NIL)))
01000 (RETURN (CDR TEM))))
01100
01200 (DFUNC (SETPROP IDENT PROPNAM PROPVAL)
01300 (PUTPROP IDENT PROPVAL PROPNAM))
01400
01500 (DFUNC (HASPROP IDENT PROP) (GETL IDENT (LIST PROP)))
01600
01700 (ENDBLOCK PROPTABLE)
01800
01900 (ENDBLOCK GENERAL)
02000
02100 (ENDBLOCK COMPILER)
02200