Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
00010 (PROG (SEXPR IBASE)
00020 (SETQ IBASE (ADD1 7))
00030 LOOP (SETQ SEXPR (ERRSET (READ)))
00040 (COND ((EQ SEXPR (QUOTE $EOF$)) (RETURN NIL)))
00050 (COND ((MEMQ (CAAR SEXPR) (QUOTE (BEGINBLOCK ENDBLOCK)))
00060 (GO LOOP)))
00070 (PRINT (EVAL (CAR SEXPR)))
00080 (GO LOOP))
00090
00100 (BEGINBLOCK COMPILER)
00110
00120 (COND ((NULL (GETL (QUOTE SPECIAL) (QUOTE (FEXPR FSUBR))))
00130 (DF SPECIAL (L) (MAPCAR (FUNCTION
00140 (LAMBDA (N) (PUTPROP N (QUOTE T) (QUOTE SPECIAL)))
00150 ) L))))
00160
00170 (DECLARE (SPECIAL LASTOUT LOCVARS SPECVARS P1CNT P2CNT FUNNAME)
00180 (SPECIAL CURBIND INPROG P1SCNT FOUNDFREE)
00190 (SPECIAL LISTING MSGCHAN INDEV OUTDEV OUTEXT)
00200 (SPECIAL ACS PDL PDLDEPTH MINDEPTH)
00210 (SPECIAL LDLST PRGSPFLG PROGVARS CCLST RSL CTAG VARLIST)
00220 (SPECIAL GOLIST EXIT EXITN PRSSL PROGSW VGO PVR)
00230 (SPECIAL NACS VALUEAC ALLACS GOTABAC FARGAC ARRAYAC)
00240 (SPECIAL ALLFUNS GENFUNS UNDFUNS CODESIZE CONSTSIZE)
00250 (SPECIAL LINCNT PAGEWIDTH PAGEHEIGHT)
00260 (SPECIAL *SP *TB *CR *LF *VT *FF *CO *PT)
00270 (SPECIAL *LP *RP *SL *AM *AT *RO *COLON)
00280 (SPECIAL IBASE BASE *NOPOINT INUM0)
00290 (SPECIAL TRACELIST SHOWNAMES))
00300
00310 (DECLARE (DEFPROP CMP T *FSUBR)
00320 (DEFPROP COMPERR T *FSUBR)
00330 (DEFPROP COMPILE T *FSUBR)
00340 (DEFPROP COMPL T *FSUBR)
00350 (DEFPROP DECLARE T *FSUBR)
00360 (DEFPROP NEXTSYM T *FSUBR)
00370 (DEFPROP PROGN T *LSUBR)
00380 (DEFPROP SPECIAL T *FSUBR)
00390 (DEFPROP STARTSYM T *FSUBR)
00400 (DEFPROP STOPSYM T *FSUBR)
00410 (DEFPROP UNSPECIAL T *FSUBR)
00420 (DEFPROP USERERR T *FSUBR))
00430
00440
00450 (BEGINBLOCK MACROS)
00460
00470 (DEFPROP DFUNC
00480 (LAMBDA (L)
00490 (LIST (Q DEFPROP)
00500 (CAADR L)
00510 (MCONS (Q LAMBDA) (CDADR L) (CDDR L))
00520 (Q EXPR)))
00530 MACRO)
00540
00550 (DEFPROP FLUSHDEF (LAMBDA (L) (CONS (Q FLUSHEXPR) (CDR L))) MACRO)
00560
00570 (DEFPROP GETPROP (LAMBDA (L) (CONS (Q GET) (CDR L))) MACRO)
00580
00590
00600 (DEFPROP IFIF
00610 (LAMBDA (L)
00620 (LIST (Q COND) (CDR L) (LIST T (CONS (Q NOT) (CDDR L)))))
00630 MACRO)
00640
00650 (DEFPROP INCR
00660 (LAMBDA (L) (LIST (Q SETQ) (CADR L) (LIST (Q ADD1) (CADR L))))
00670 MACRO)
00680
00690 (DEFPROP MAPDEF
00700 (LAMBDA (L)
00710 (LIST (Q MAPCAR)
00720 (SUBST (CADR L)
00730 (Q IND)
00740 (Q (FUNCTION (LAMBDA (PAIR)
00750 (PUTPROP (CAR PAIR)
00760 (CADR PAIR)
00770 (QUOTE IND))))))
00780 (LIST (Q QUOTE) (CDDR L))))
00790 MACRO)
00800
00810 (DEFPROP MCONS
00820 (LAMBDA (L)
00830 (COND ((NULL (CDDR L)) (CADR L))
00840 (T (LIST (Q CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
00850 MACRO)
00860
00870 (DEFPROP OUTINST (LAMBDA (INST) (CONS (Q OUTSTAT) (CDR INST))) MACRO)
00880
00890 (DEFPROP OUTPSOP (LAMBDA (PSOP) (CONS (Q OUTSTAT) (CDR PSOP))) MACRO)
00900
00910 (DEFPROP OUTTAG (LAMBDA (TAG) (CONS (Q OUTSTAT) (CDR TAG))) MACRO)
00920
00930 (DEFPROP PDLDEPTH (LAMBDA (L) (Q PDLDEPTH)) MACRO)
00940
00950 (DEFPROP Q (LAMBDA (L) (CONS (QUOTE QUOTE) (CDR L))) MACRO)
00960
00970 (DEFPROP TAGP (LAMBDA (L) (CONS (Q ATOM) (CDR L))) MACRO)
00980
00990 (DEFPROP USERWARN
01000 (LAMBDA (L)
01010 (LIST (Q PRINTMSG)
01020 (LIST (Q APPEND)
01030 (LIST (Q LIST) (CADR L))
01040 (LIST (Q Q) (APPEND (CDDR L) (Q (IN))))
01050 (Q (LIST (CURFUN))))))
01060 MACRO)
01070
01080 (BEGINBLOCK PROPTABLE)
01090
01100 (DEFPROP FIRSTPROP (LAMBDA (L) (CONS (Q CDR) (CDR L))) MACRO)
01110
01120
01130 (DEFPROP LASTPROP (LAMBDA (L) (CONS (Q NULL) (CDR L))) MACRO)
01140
01150 (DEFPROP NEXTPROP (LAMBDA (L) (CONS (Q CDDR) (CDR L))) MACRO)
01160
01170 (DEFPROP PROPNAM (LAMBDA (L) (CONS (Q CAR) (CDR L))) MACRO)
01180
01190 (DEFPROP PROPTABLE (LAMBDA (L) (CONS (Q CDR) (CDR L))) MACRO)
01200
01210 (DEFPROP PROPVAL (LAMBDA (L) (CONS (Q CADR) (CDR L))) MACRO)
01220
01230 (DFUNC (DELETEPROP IDENT PROPNAM)
01240 (PROG (TEM)
01250 (SETQ TEM IDENT)
01260 LOOP (COND ((NULL (CDR TEM)) (RETURN NIL)))
01270 (COND ((EQ (CADR TEM) PROPNAM) (RPLACD TEM (CDDDR TEM))
01280 (RETURN T)))
01290 (SETQ TEM (CDDR TEM))
01300 (GO LOOP)))
01310
01320 (DFUNC (HASPROP IDENT PROP) (GETL IDENT (LIST PROP)))
01330
01340 (DFUNC (INITPROP IDENT PROPNAM PROPVAL)
01350 (RPLACD IDENT (MCONS PROPNAM PROPVAL (CDR IDENT))))
01360
01370 (DFUNC (SEEKPROP IDENT PROPNAM)
01380 (PROG (TEM)
01390 (SETQ TEM (GETL IDENT (LIST PROPNAM)))
01400 (COND ((NULL TEM) (RETURN NIL)))
01410 (RETURN TEM)))
01420
01430 (DFUNC (SETPROP IDENT PROPNAM PROPVAL)
01440 (PUTPROP IDENT PROPVAL PROPNAM))
01450
01460 (ENDBLOCK PROPTABLE)
01470
01480 (ENDBLOCK MACROS)
01490
01500 (BEGINBLOCK TOPLEVEL)
01510
01520 (DFUNC (ACTONEXPR XPR)
01530 (PROG (ACTION)
01540 (COND ((ATOM XPR) (GO FLUSH)))
01550 (SETQ ACTION (GETGET (CAR XPR) (Q COMPEFFECT)))
01560 (COND (ACTION ((PROPVAL ACTION) XPR) (RETURN NIL)))
01570 FLUSH(FLUSHEXPR XPR)
01580 (RETURN NIL)))
01590
01600 (DFUNC (ACTONMACRO XPR)
01610 (ACTONEXPR ((GETPROP (CAR XPR) (Q MACRO)) XPR)))
01620
01630
01640 (DEFPROP CMP
01650 (LAMBDA (L)
01660 (COND ((NULL L) NIL)
01670 ((NULL (CDR L)) (COMPILEFUN (CAR L)))
01680 (T (PUTPROP (CAAR L)
01690 (MCONS (Q LAMBDA) (CDAR L) (CDR L))
01700 (COND ((NULL (CDDR L)) (Q EXPR)) (T (CADDR L))))
01710 (COMPILEFUN (CAAR L)))))
01720 FEXPR)
01730
01740 (DFUNC (COMPDEF DEFIN)
01750 (PROG (ACTION)
01760 (COND ((NOT (EQUAL (LENGTH DEFIN) 4))
01770 (USERERR ARGNOERR-COMPDEF)))
01780 (COND ((SETQ ACTION (SEEKPROP (CADDDR DEFIN) (Q DEFACTION)))
01790 ((PROPVAL ACTION) DEFIN)
01800 (RETURN NIL)))
01810 (FLUSHDEF DEFIN)
01820 (RETURN NIL)))
01830
01840 (DFUNC (COMPFILE INFILE OUTFILE)
01850 (PROG (ALLFUNS UNDFUNS GENFUNS CODESIZE CONSTSIZE STARTTIME)
01860 (INITPROP (Q CURFILE) (Q NAME) INFILE)
01870 (SETQ STARTTIME (TIME))
01880 (SETQ CODESIZE (SETQ CONSTSIZE 0))
01890 (DOFILE (FUNCTION COMPREADS) INFILE OUTFILE)
01900 (TELLTALE (CADR INFILE) STARTTIME)
01910 (DELETEPROP (Q CURFILE) (Q NAME))))
01920
01930 (DFUNC (COMPFUNC NAME EXPR FLAG)
01940 (PROG (LOCVARS SPECVARS P1CNT P2CNT LASTOUT)
01950 (STARTSYM VAL VAR TAG)
01960 (INITPROP (Q CURFUN) (Q NAME) NAME)
01970 (PASS2 NAME (PASS1 NAME EXPR FLAG) FLAG)
01980 (DELETEPROP (Q CURFUN) (Q NAME))
01990 (STOPSYM VAL VAR TAG)
02000 (COND ((NOT (EQUAL P2CNT P1CNT))
02010 (PRINTMSG (LIST P1CNT P2CNT))
02020 (COMPERR COUNTSDISAGREE-COMPFUNC)))
02030 (RETURN NAME)))
02040
02050 (DEFPROP COMPILE
02060 (LAMBDA (NAMES)
02070 (PROG (DONE)
02080 LOOP (COND ((NULL NAMES) (OUTC NIL T) (RETURN DONE)))
02090 (COND ((NOT (ATOM (CAR NAMES)))
02100 (OUTC (EVAL (CONS (Q OUTPUT) (CAR NAMES))) NIL))
02110 (T (SETQ DONE (APPEND DONE (COMPILEFUN (CAR NAMES))))))
02120 (SETQ NAMES (CDR NAMES))
02130 (GO LOOP)))
02140 FEXPR)
02150
02160
02170 (DFUNC (COMPILEFUN NAME)
02180 (PROG (GENFUNS UNDFUNS CODESIZE CONSTSIZE MSGCHAN SHOWNAMES PROP
02190 DONE PLIST)
02200 (SETQ CODESIZE (SETQ CONSTSIZE 0))
02210 (SETQ PLIST (CDR NAME))
02220 LOOP (COND ((NULL PLIST) (RETURN (REVERSE DONE))))
02230 (SETQ PROP (SEEKPROP (CAR PLIST) (Q DEFACTION)))
02240 (COND ((NULL PROP) (GO ELOOP)))
02250 (SETQ DONE (CONS (CONS NAME (CAR PLIST)) DONE))
02260 ((PROPVAL PROP)
02270 (LIST (Q DEFPROP) NAME (CADR PLIST) (CAR PLIST)))
02280 ELOOP(SETQ PLIST (CDDR PLIST))
02290 (GO LOOP)))
02300
02310 (DEFPROP COMPL
02320 (LAMBDA (FILES)
02330 (PROG (MSGCHAN)
02340 (COND ((NOT (NULL LISTING))
02350 (SETQ MSGCHAN (EVAL (MCONS (Q OUTPUT)
02360 (GENSYM)
02370 LISTING)))))
02380 LOOP (COND ((NULL FILES) (OUTC MSGCHAN NIL)
02390 (OUTC NIL T)
02400 (RETURN NIL)))
02410 (COND ((OR (EQ (CAR (LAST (EXPLODE (CAR FILES)))) *COLON)
02420 (AND (NOT (ATOM (CAR FILES)))
02430 (NOT (ATOM (CDAR FILES)))))
02440 (SETQ INDEV (CAR FILES))
02450 (GO ELOOP)))
02460 (COMPFILE (LIST INDEV (CAR FILES))
02470 (LIST OUTDEV
02480 (CONS (COND ((ATOM (CAR FILES)) (CAR FILES))
02490 (T (CAAR FILES)))
02500 OUTEXT)))
02510 ELOOP(SETQ FILES (CDR FILES))
02520 (GO LOOP)))
02530 FEXPR)
02540
02550 (DFUNC (COMPREADS) (READLOOP (FUNCTION ACTONEXPR)))
02560
02570 (DFUNC (CURFILE) (GETPROP (Q CURFILE) (Q NAME)))
02580
02590 (DFUNC (CURFUN) (GETPROP (Q CURFUN) (Q NAME)))
02600
02610 (DEFPROP DECLARE (LAMBDA (L) (MAPC (FUNCTION EVAL) L)) FEXPR)
02620
02630
02640 (DFUNC (DEFEXPR DEF)
02650 (PROG (FN EX)
02660 (SETQ FN (CADR DEF))
02670 (SETQ EX (CADDR DEF))
02680 (COND ((OR (ATOM EX) (NOT (EQ (CAR EX) (Q LAMBDA))))
02690 (FLUSHDEF DEF))
02700 ((AND (ATOM (CADR EX)) (NOT (NULL (CADR EX))))
02710 (COND ((REMPROP FN (Q *UNDEF))
02720 (PRINTMSG (CONS FN (Q (LSUBR USED AS SUBR))))))
02730 (PUTPROP FN T (Q *LSUBR))
02740 (COMPFUNC FN
02750 (MCONS (Q LSUBR) (LIST (CADR EX)) (CDDR EX))
02760 (Q LSUBR)))
02770 (T (REMPROP FN (Q *UNDEF))
02780 (PUTPROP FN T (Q *SUBR))
02790 (COMPFUNC FN (CONS (Q SUBR) (CDR EX)) (Q SUBR))))
02800 (TYPEFN FN)))
02810
02820 (DFUNC (DEFFEXPR DEF)
02830 (PROG (FN EX)
02840 (SETQ FN (CADR DEF))
02850 (SETQ EX (CADDR DEF))
02860 (COND ((REMPROP FN (Q *UNDEF))
02870 (PRINTMSG (CONS FN (Q (FSUBR USED AS SUBR))))))
02880 (PUTPROP FN T (Q *FSUBR))
02890 (COMPFUNC FN (CONS (Q FSUBR) (CDR EX)) (Q FSUBR))
02900 (TYPEFN FN)))
02910
02920 (DFUNC (DEFMACRO DEF)
02930 (PROGN (COND ((REMPROP (CADR DEF) (Q *UNDEF))
02940 (PRINTMSG (CONS (CADR DEF)
02950 (Q (MACRO USED AS SUBR))))))
02960 (PUTPROP (CADR DEF) (CADDR DEF) (Q MACRO))
02970 (TYPEFN (CADR DEF))))
02980
02990 (DFUNC (DO*EXPR DEF) (PUTPROP (CADR DEF) (CADDR DEF) (Q *SUBR)))
03000
03010 (DFUNC (DO*FEXPR DEF) (PUTPROP (CADR DEF) (CADDR DEF) (Q *FSUBR)))
03020
03030 (DFUNC (DOACT XPR) ((GETPROP (CAR XPR) (Q COMPACTION)) XPR))
03040
03050 (DFUNC (DODE L)
03060 (DEFEXPR (MAKDEF (CADR L) (CADDR L) (CADDDR L) (Q EXPR))))
03070
03080 (DFUNC (DODF L)
03090 (DEFFEXPR (MAKDEF (CADR L) (CADDR L) (CADDDR L) (Q FEXPR))))
03100
03110 (DFUNC (DODM L)
03120 (DEFMACRO (MAKDEF (CADR L) (CADDR L) (CADDDR L) (Q MACRO))))
03130
03140
03150 (DFUNC (DOFILE DOREADS INFILE OUTFILE)
03160 (PROG (LINCNT)
03170 (SETQ LINCNT 0)
03180 (EVAL (MCONS (Q INPUT) (Q INCHAN) INFILE))
03190 (EVAL (MCONS (Q OUTPUT) (Q OUTCHAN) OUTFILE))
03200 (INC (Q INCHAN) NIL)
03210 (OUTC (Q OUTCHAN) NIL)
03220 (DOREADS)
03230 (OUTC NIL T)
03240 (INC NIL T)))
03250
03260 (DFUNC (FLUSHEXPR EXPR)
03270 (PROG2 (COND ((NOT (ATMARGIN)) (LINEF 2))) (PRINTEXPR EXPR)))
03280
03290 (DFUNC (FLUSHLAP ENTRY)
03300 (PROG (NAME FLAG TYPE STAT)
03310 (SETQ NAME (CADR ENTRY))
03320 (SETQ FLAG (CADDR ENTRY))
03330 (SETQ TYPE (ASSOC FLAG
03340 (Q ((FSUBR *FSUBR) (LSUBR *LSUBR)
03350 (SUBR *SUBR)))))
03360 (COND ((NULL TYPE) (GO PRINT)))
03370 (SETQ TYPE (CADR TYPE))
03380 (COND ((AND (MEMQ TYPE (Q (*FSUBR *LSUBR)))
03390 (GETPROP NAME (Q *UNDEF)))
03400 (PRINTMSG (MCONS NAME FLAG (Q (USED AS SUBR))))))
03410 (SETPROP NAME TYPE T)
03420 (REMPROP NAME (Q *UNDEF))
03430 (TYPEFN NAME)
03440 PRINT(COND ((NOT (ATMARGIN)) (LINEF 2)))
03450 (OUTPUTSTAT ENTRY)
03460 LOOP (SETQ STAT (ERRSET (READ)))
03470 (COND ((ATOM STAT) (USERERR READERR-FLUSHLAP)))
03480 (OUTPUTSTAT (CAR STAT))
03490 (COND ((NULL (CAR STAT)) (RETURN NIL)))
03500 (GO LOOP)))
03510
03520 (DFUNC (MAKDEF NAME ARGS BODY TYPE)
03530 (LIST (Q DEFPROP) NAME (LIST (Q LAMBDA) ARGS BODY) TYPE))
03540
03550 (DFUNC (MAPPUT EXP)
03560 (PROG (IND ARGS)
03570 (SETQ IND (CAR EXP))
03580 (SETQ ARGS (CDR EXP))
03590 LOOP (COND ((NULL ARGS) (RETURN EXP)))
03600 (PUTPROP (CAR ARGS) T IND)
03610 (SETQ ARGS (CDR ARGS))
03620 (GO LOOP)))
03630
03640
03650 (DFUNC (PRINTMSG MESSAGE)
03660 (PROG (CHAN LINCNT)
03670 (SETQ CHAN (OUTC MSGCHAN NIL))
03680 (SETQ LINCNT 0)
03690 (COND ((NOT (ATMARGIN)) (LINEF 2)))
03700 (PRINL (CONS (Q *) MESSAGE))
03710 (LINEF 1)
03720 (OUTC CHAN NIL)))
03730
03740 (DFUNC (READLOOP ACTFUN)
03750 (PROG (EXPR)
03760 LOOP (SETQ EXPR (ERRSET (READ)))
03770 (COND ((EQ EXPR (Q $EOF$)) (RETURN NIL)))
03780 (ACTFUN (CAR EXPR))
03790 (GO LOOP)))
03800
03810 (DEFPROP SPECIAL
03820 (LAMBDA (X) (MAPCAR (FUNCTION MAKESPECIAL) X))
03830 FEXPR)
03840
03850 (DFUNC (TELLTALE FILENAME STARTTIME)
03860 (PROG (CHAN UNDS)
03870 (SETQ CHAN (OUTC MSGCHAN NIL))
03880 (CARRETN)
03890 (LINEF 1)
03900 (PRINL (LIST FILENAME (Q COMPILED)))
03910 (PRINL (LIST CODESIZE (Q WORDS)))
03920 (PRINL (LIST CONSTSIZE (Q CONSTANTS)))
03930 (PRINL (LIST (ADD1 (QUOTIENT (DIFFERENCE (TIME) STARTTIME)
03940 1750))
03950 (Q SECONDS)))
03960 (LINEF 2)
03970 UNDF (COND ((NULL UNDFUNS) (GO UNDF1)))
03980 (COND ((HASPROP (CAR UNDFUNS) (Q *UNDEF))
03990 (SETQ UNDS (CONS (CAR UNDFUNS) UNDS))))
04000 (SETQ UNDFUNS (CDR UNDFUNS))
04010 (GO UNDF)
04020 UNDF1(COND ((NULL UNDS) (GO GENF)))
04030 (PRINL (Q (UNDEFINED FUNCTIONS)))
04040 (LINEF 1)
04050 (PRINL UNDS)
04060 (LINEF 2)
04070 GENF (COND ((NULL GENFUNS) (GO END)))
04080 (PRINL (Q (GENERATED FUNCTIONS)))
04090 (LINEF 1)
04100 (PRINL GENFUNS)
04110 (LINEF 2)
04120 END (OUTC CHAN NIL)))
04130
04140
04150 (DFUNC (TYPEFN MESSAGE)
04160 (PROG (CHAN LINCNT)
04170 (COND ((NULL SHOWNAMES) (RETURN NIL)))
04180 (SETQ CHAN (OUTC MSGCHAN NIL))
04190 (SETQ LINCNT 0)
04200 (COND ((ATMARGIN) (LINEF 1)))
04210 (PRINS MESSAGE)
04220 (OUTC CHAN NIL)))
04230
04240 (DEFPROP UNSPECIAL
04250 (LAMBDA (X) (MAPCAR (FUNCTION MAKEUNSPECIAL) X))
04260 FEXPR)
04270
04280 (BEGINBLOCK INITIALIZATION)
04290
04300 (DFUNC (CINIT) (PROG2 (EXCISE) (INITFN (Q CSTART)) (NOUUO NIL)))
04310
04320 (DFUNC (CSTART)
04330 (PROGN (INITFN NIL)
04340 (COND ((NOT (NULL (ERRSET (INPUT SYS: (COMPLR . INI)) NIL)))
04350 (SYSIN (COMPLR . INI))))
04360 (COND ((NOT (NULL (ERRSET (INPUT DSK: (COMPLR . INI)) NIL)))
04370 (SYSIN DSK: (COMPLR . INI))))
04380 (LINEF 1)
04390 (PRINL (Q (LISP COMPILER)))))
04400
04410 (ENDBLOCK INITIALIZATION)
04420
04430 (MAPDEF COMPEFFECT (COMPACTION DOACT) (MACRO ACTONMACRO))
04440
04450 (MAPDEF COMPACTION (DE DODE) (DECLARE EVAL) (DEFPROP COMPDEF)
04460 (DF DODF) (DM DODM) (LAP FLUSHLAP) (SPECIAL EVAL)
04470 (UNSPECIAL EVAL) (*SUBR MAPPUT) (*FSUBR MAPPUT)
04480 (*LSUBR MAPPUT) (*EXPR MAPPUT) (*FEXPR MAPPUT))
04490
04500 (MAPDEF DEFACTION (EXPR DEFEXPR) (FEXPR DEFFEXPR) (MACRO DEFMACRO)
04510 (SPECIAL EVAL) (DEFACTION EVAL) (*EXPR DO*EXPR)
04520 (*FEXPR DO*FEXPR) (*SUBR EVAL) (*FSUBR EVAL)
04530 (*LSUBR EVAL))
04540
04550 (SETQ LISTING NIL)
04560
04570 (SETQ OUTDEV (SETQ INDEV (QUOTE DSK:)))
04580
04590 (SETQ OUTEXT (QUOTE LAP))
04600
04610 (SETQ SHOWNAMES T)
04620
04630 (ENDBLOCK TOPLEVEL)
04640
04650 (BEGINBLOCK PASS1)
04660
04670
04680 (DFUNC (DOP1 XPR) ((GETPROP (CAR XPR) (Q P1)) XPR))
04690
04700 (DFUNC (GENFUN EXPR)
04710 (PROG (NAME ARGS CALL)
04720 (COND ((ATOM EXPR) (RETURN EXPR)))
04730 (COND ((NOT (EQ (CAR EXPR) (Q LAMBDA)))
04740 (USERERR NOTLAMBDA-GENFUN)))
04750 (SETQ ARGS (CADR EXPR))
04760 (SETQ CALL (CADDR EXPR))
04770 (COND ((AND (ATOM (CAR CALL)) (EQUAL ARGS (CDR CALL)))
04780 (RETURN (CAR CALL))))
04790 (SETQ NAME (MAKESYM (NEXTSYM SUBFUN) (CURFUN)))
04800 (SETQ GENFUNS (CONS NAME GENFUNS))
04810 (RETURN (COMPFUNC NAME (LIST (Q SUBR) ARGS CALL) (Q SUBR)))))
04820
04830 (DFUNC (MAPP1 ARGS) (MAPCAR (FUNCTION P1) ARGS))
04840
04850 (DFUNC (P1 XPR)
04860 (PROG (TEM)
04870 (COND ((ATOM XPR) (GO ATOM)))
04880 (COND ((ATOM (CAR XPR)) (GO ATOMC)))
04890 (COND ((EQ (CAAR XPR) (Q LAMBDA))
04900 (RETURN (P1LAM XPR CURBIND))))
04910 (COND ((EQ (CAAR XPR) (Q LABEL)) (RETURN (P1LABEL XPR))))
04920 (RETURN (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))
04930 ATOM (COND ((CONSTANTP XPR) (RETURN (LIST (Q QUOTE) XPR))))
04940 (COND ((SETQ TEM (ASSOC XPR CURBIND)) (SETQ XPR (CDR TEM))))
04950 (INCR P1CNT)
04960 (COND ((SPECIALP XPR) (SETQ SPECVARS (ADDTOLIST XPR SPECVARS))
04970 (RETURN XPR)))
04980 (COND ((VARB XPR) (RETURN XPR)))
04990 (RPLACD (ASSOC XPR LOCVARS) P1CNT)
05000 (RETURN XPR)
05010 ATOMC(COND ((CONSTANTP (CAR XPR)) (USERERR CONSTFUN-P1)))
05020 (COND ((SETQ TEM (GETGET (CAR XPR) (Q PASS1)))
05030 (RETURN ((PROPVAL TEM) XPR))))
05040 (COND ((SETQ TEM (ASSOC (CAR XPR) CURBIND))
05050 (SETQ XPR (CONS (CDR TEM) (CDR XPR)))))
05060 (COND ((OR (SPECIALP (CAR XPR)) (ASSOC (CAR XPR) LOCVARS))
05070 (RETURN (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))))
05080 (RETURN (P1ELSE XPR))))
05090
05100 (DFUNC (P1ANDOR XPR)
05110 (PROG (TEM CT ARGS)
05120 (SETQ TEM LOCVARS)
05130 (SETQ CT P1CNT)
05140 (SETQ ARGS (MAPP1 (CDR XPR)))
05150 (INCR P1CNT)
05160 (P1BUG CT P1CNT TEM)
05170 (RETURN (CONS (CAR XPR) ARGS))))
05180
05190
05200 (DFUNC (P1BIND VARS)
05210 (PROG (VAR NEWVARS)
05220 (COND ((AND VARS (ATOM VARS)) (USERERR ATOMICVARLIST-P1BIND)))
05230 LOOP (COND ((NULL VARS) (RETURN (REVERSE NEWVARS))))
05240 (SETQ VAR (CAR VARS))
05250 (COND ((NOT (VARIABLEP VAR)) (USERERR NOTVARIABLE-P1BIND)))
05260 (COND ((MEMBER VAR NEWVARS) (USERWARN VAR REPEATED VARIABLE)))
05270 (COND ((SPECIALP VAR) (SETQ SPECVARS (ADDTOLIST VAR SPECVARS))
05280 (GO ELOOP)))
05290 (SETQ CURBIND (CONS (CONS VAR
05300 (SETQ VAR (COND ((ASSOC VAR LOCVARS)
05310 (NEXTSYM VAR))
05320 (T VAR))))
05330 CURBIND))
05340 (SETQ LOCVARS (CONS (CONS VAR 0) LOCVARS))
05350 ELOOP(SETQ NEWVARS (CONS VAR NEWVARS))
05360 (SETQ VARS (CDR VARS))
05370 (GO LOOP)))
05380
05390 (DFUNC (P1BUG LOW HIGH PTR)
05400 (PROG (X)
05410 LOOP (COND ((NULL PTR) (RETURN NIL)))
05420 (SETQ X (CAR PTR))
05430 (COND ((GREATERP (CDR X) LOW) (RPLACD X HIGH)))
05440 (SETQ PTR (CDR PTR))
05450 (GO LOOP)))
05460
05470 (DFUNC (P1COND XPR)
05480 (PROG (TEM CT PAIRS)
05490 (SETQ TEM LOCVARS)
05500 (SETQ CT P1CNT)
05510 (SETQ PAIRS (MAPCAR (FUNCTION MAPP1) (CDR XPR)))
05520 (INCR P1CNT)
05530 (P1BUG CT P1CNT TEM)
05540 (INCR P1CNT)
05550 (RETURN (CONS (CAR XPR) PAIRS))))
05560
05570 (DFUNC (P1CONS XPR)
05580 (COND ((NOT (EQ (LENGTH (CDR XPR)) 2)) (USERERR ARGNO-P1CONS))
05590 ((NULL (CADDR XPR)) (LIST (Q NCONS) (P1 (CADR XPR))))
05600 (T (LIST (Q CONS) (P1 (CADR XPR)) (P1 (CADDR XPR))))))
05610
05620 (DFUNC (P1ELSE XPR)
05630 (PROGN (SETQ UNDFUNS (CONS (CAR XPR) UNDFUNS))
05640 (PUTPROP (CAR XPR) T (Q *UNDEF))
05650 (CONS (CAR XPR) (P1SUBRARGS (CDR XPR)))))
05660
05670
05680 (DFUNC (P1ERRSET XPR)
05690 (COND ((ATOM (CADR XPR)) XPR)
05700 (T (MCONS (CAR XPR)
05710 (LIST (GENFUN (LIST (Q LAMBDA) NIL (CADR XPR))))
05720 (CDDR XPR)))))
05730
05740 (DFUNC (P1EVAL XPR)
05750 (PROG (CDRXPR)
05760 (SETQ CDRXPR (P1SUBRARGS (CDR XPR)))
05770 (COND ((NOT (NULL (CDR CDRXPR)))
05780 (RETURN (CONS (Q EVAL) CDRXPR))))
05790 (RETURN (CONS (Q *EVAL) CDRXPR))))
05800
05810 (DFUNC (P1FUNCTION XPR) (LIST (Q QUOTE) (GENFUN (CADR XPR))))
05820
05830 (DFUNC (P1*FUNCTION XPR) (LIST (Q *FUNCTION) (GENFUN (CADR XPR))))
05840
05850 (DFUNC (P1GO XPR)
05860 (PROGN (COND ((NOT INPROG) (USERERR NOTINPROG-P1GO)))
05870 (COND ((ATOM (CADR XPR)) XPR)
05880 (T (LIST (CAR XPR) (P1 (CADR XPR)))))))
05890
05900 (DFUNC (P1LABEL XPR)
05910 (PROG (FN)
05920 (INITPROP (CADAR XPR) (Q FUNVAR) T)
05930 (SETQ FN (P1 (LIST (Q FUNCTION) (CADDAR XPR))))
05940 (DELETEPROP (CADAR XPR) (Q FUNVAR))
05950 (RETURN (P1 (LIST (Q PROG)
05960 (LIST (CADAR XPR))
05970 (LIST (Q SETQ) (CADAR XPR) FN)
05980 (LIST (Q RETURN)
05990 (CONS (CADAR XPR) (CDR XPR))))))))
06000
06010 (DFUNC (P1LAM XPR CURBIND)
06020 (PROG (ARGS VARS BODY)
06030 (SETQ ARGS (P1SUBRARGS (CDR XPR)))
06040 (INCR P1CNT)
06050 (SETQ VARS (P1BIND (CADAR XPR)))
06060 (COND ((NOT (EQUAL (LENGTH ARGS) (LENGTH VARS)))
06070 (USERERR ARGNOERR-P1LAM)))
06080 (SETQ BODY (P1 (CADDAR XPR)))
06090 (INCR P1CNT)
06100 (RETURN (CONS (LIST (Q LAMBDA) VARS BODY) ARGS))))
06110
06120
06130 (DFUNC (P1PROG X)
06140 ((LAMBDA (CURBIND)
06150 (PROG (TAGLIST P1SCNT PR TEM P1LL INPROG)
06160 (COND ((NULL (CDR X)) (USERERR PROGTOOSHORT-P1PROG)))
06170 (SETQ INPROG T)
06180 (SETQ X (CDR X))
06190 (SETQ P1LL (P1BIND (CAR X)))
06200 (SETQ TEM LOCVARS)
06210 (SETQ P1SCNT (INCR P1CNT))
06220 LOOP1(SETQ X (CDR X))
06230 (COND ((NULL X) (GO END1)))
06240 (INCR P1CNT)
06250 (COND ((ATOM (CAR X))
06260 (COND ((ASSOC (CAR X) TAGLIST)
06270 (USERWARN (CAR X) MULTIPLY DEFINED TAG)))
06280 (SETQ TAGLIST (CONS (CONS (CAR X) (NEXTSYM TAG))
06290 TAGLIST))
06300 (SETQ PR (CONS (CAR X) PR)))
06310 (T (SETQ PR (CONS (P1 (CAR X)) PR))))
06320 (GO LOOP1)
06330 END1 (INCR P1CNT)
06340 (P1BUG P1SCNT P1CNT TEM)
06350 (SETQ TEM (GETPROP (Q LOCVARS) (Q VALUE)))
06360 LOOP (COND ((NULL (CDR TEM)) (GO END)))
06370 (COND ((AND (MEMBER (CAADR TEM) P1LL) (ZEROP (CDADR TEM)))
06380 (USERWARN (CAADR TEM) UNUSED PROG VARIABLE)
06390 (SETQ SPECVARS (ADDTOLIST (CAADR TEM) SPECVARS))
06400 (MAKESPECIAL (CAADR TEM))))
06410 ELOOP(SETQ TEM (CDR TEM))
06420 (GO LOOP)
06430 END (INCR P1CNT)
06440 (RETURN (MCONS (Q PROG) TAGLIST P1LL (REVERSE PR)))))
06450 CURBIND))
06460
06470 (DFUNC (P1RETURN XPR)
06480 (COND ((NOT INPROG) (USERERR NOTINPROG-P1RETURN))
06490 (T (LIST (Q RETURN)
06500 (P1 (COND ((NULL (CDR XPR)) NIL) (T (CADR XPR))))))))
06510
06520 (DFUNC (P1SETQ XPR)
06530 (PROG (VAR TEM VAL)
06540 (COND ((NOT (VARIABLEP (CAR XPR)))
06550 (USERERR NOTVARIABLE-P1SETQ)))
06560 (SETQ VAR (COND ((SETQ TEM (ASSOC (CADR XPR) CURBIND))
06570 (CDR TEM))
06580 (T (CADR XPR))))
06590 (VARB VAR)
06600 (SETQ VAL (P1 (CADDR XPR)))
06610 (INCR P1CNT)
06620 (INCR P1CNT)
06630 (RETURN (LIST (Q SETQ) VAR VAL))))
06640
06650
06660 (DFUNC (P1STORE XPR)
06670 (PROG (ARG1 ARG2)
06680 (SETQ ARG2 (P1 (CADDR XPR)))
06690 (SETQ ARG1 (P1 (CADR XPR)))
06700 (RETURN (LIST (CAR XPR) ARG1 ARG2))))
06710
06720 (DFUNC (P1SUBRARGS ARGS)
06730 (COND ((GREATERP (LENGTH ARGS) NACS) (USERERR EXTRAARGS-P1SUBRARGS))
06740 (T (MAPP1 ARGS))))
06750
06760 (DFUNC (PASS1 NAME EXPR FLAG)
06770 (PROG (LL CURBIND P1SCNT INPROG FOUNDFREE LOCVS)
06780 (SETQ INPROG NIL)
06790 (SETQ P1CNT 1)
06800 (SETQ LOCVARS (SETQ SPECVARS NIL))
06810 (SETQ LL (P1BIND (CADR EXPR)))
06820 (COND ((GREATERP (LENGTH LL) NACS) (USERERR EXTRAARGS-PASS1)))
06830 (STARTSYM SUBFUN)
06840 (SETQ EXPR (LIST (CAR EXPR) LL (P1 (CADDR EXPR))))
06850 (STOPSYM SUBFUN)
06860 (COND ((NOT (NULL FOUNDFREE)) (USERWARN (REVERSE FOUNDFREE)
06870 UNDECLARED
06880 FREE
06890 VARIABLES)))
06900 (SETQ LOCVS LOCVARS)
06910 (SETQ LOCVARS NIL)
06920 LOOP (COND ((NULL LOCVS) (RETURN EXPR)))
06930 (COND ((NOT (SPECIALP (CAAR LOCVS)))
06940 (SETQ LOCVARS (CONS (CAR LOCVS) LOCVARS))
06950 (SETPROP (CAAR LOCVS) (Q LOCAL) T))
06960 (T (SETQ SPECVARS (ADDTOLIST (CAAR LOCVS) SPECVARS))))
06970 (SETQ LOCVS (CDR LOCVS))
06980 (GO LOOP)))
06990
07000 (DFUNC (PASS1FSUBR XPR) XPR)
07010
07020 (DFUNC (PASS1FUNVAR XPR)
07030 (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))
07040
07050 (DFUNC (PASS1LSUBR XPR) (CONS (CAR XPR) (MAPP1 (CDR XPR))))
07060
07070 (DFUNC (PASS1MACRO XPR) (P1 ((GETPROP (CAR XPR) (Q MACRO)) XPR)))
07080
07090 (DFUNC (PASS1SUBR XPR) (CONS (CAR XPR) (P1SUBRARGS (CDR XPR))))
07100
07110 (DFUNC (PASS1UNDEF XPR)
07120 (PROG2 (SETQ UNDFUNS (ADDTOLIST (CAR XPR) UNDFUNS))
07130 (PASS1SUBR XPR)))
07140
07150 (DFUNC (SPECIALP VAR) (HASPROP VAR (Q SPECIAL)))
07160
07170
07180 (DFUNC (VARB X)
07190 (PROG NIL
07200 (COND ((ASSOCR X CURBIND) (RETURN NIL))
07210 ((SPECIALP X) (GO SPEC)))
07220 (SETQ FOUNDFREE (CONS X FOUNDFREE))
07230 (MAKESPECIAL X)
07240 SPEC (SETQ SPECVARS (ADDTOLIST X SPECVARS))
07250 (RETURN T)))
07260
07270 (DFUNC (VARIABLEP EX) (AND (ATOM EX) (NOT (CONSTANTP EX))))
07280
07290 (MAPDEF PASS1 (EXPR PASS1SUBR) (*EXPR PASS1SUBR) (SUBR PASS1SUBR)
07300 (*SUBR PASS1SUBR) (*UNDEF PASS1UNDEF)
07310 (LSUBR PASS1LSUBR) (*LSUBR PASS1LSUBR)
07320 (FEXPR PASS1FSUBR) (*FEXPR PASS1FSUBR)
07330 (FSUBR PASS1FSUBR) (*FSUBR PASS1FSUBR) (P1 DOP1)
07340 (FUNVAR PASS1FUNVAR) (MACRO PASS1MACRO))
07350
07360 (MAPDEF P1 (COND P1COND) (GO P1GO) (PROG P1PROG) (EVAL P1EVAL)
07370 (ERRSET P1ERRSET) (SETQ P1SETQ) (STORE P1STORE)
07380 (AND P1ANDOR) (CONS P1CONS) (OR P1ANDOR)
07390 (*FUNCTION P1*FUNCTION) (FUNCTION P1FUNCTION)
07400 (RETURN P1RETURN))
07410
07420 (BEGINBLOCK INTERNALMACROS)
07430
07440 (DEFPROP INMACRO PASS1INMACRO PASS1)
07450
07460 (DFUNC (PASS1INMACRO XPR) (P1 ((GETPROP (CAR XPR) (Q INMACRO)) XPR)))
07470
07480 (DEFPROP INMACRO
07490 (LAMBDA (DF)
07500 (COMPFUNC (CADR DF) (CONS (Q SUBR) (CDADDR DF)) (Q INMACRO)))
07510 DEFACTION)
07520
07530 (DEFPROP APPEND
07540 (LAMBDA (L)
07550 (COND ((NULL (CDR L)) NIL)
07560 ((NULL (CDDR L)) (CADR L))
07570 (T (LIST (Q *APPEND) (CADR L) (CONS (CAR L) (CDDR L))))))
07580 INMACRO)
07590
07600 (DEFPROP LIST
07610 (LAMBDA (L)
07620 (COND ((NULL (CDR L)) NIL)
07630 ((NULL (CDDR L)) (CONS (Q NCONS) (CDR L)))
07640 (T (LIST (Q CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
07650 INMACRO)
07660
07670 (DEFPROP NOT (LAMBDA (L) (CONS (Q NULL) (CDR L))) INMACRO)
07680
07690
07700 (DEFPROP ZEROP (LAMBDA (L) (LIST (Q EQ) (CADR L) (Q 0))) INMACRO)
07710
07720 (ENDBLOCK INTERNALMACROS)
07730
07740 (ENDBLOCK PASS1)
07750
07760 (BEGINBLOCK PASS2)
07770
07780 (DFUNC (ACEFFECTS FN)
07790 (COND ((SETQ FN (SEEKPROP FN (Q ACS))) (PROPVAL FN)) (T ALLACS)))
07800
07810 (DFUNC (ACNUMP X)
07820 (AND (NUMBERP X) (GREATERP X 0) (LESSP X (ADD1 NACS))))
07830
07840 (DFUNC (BINDARGS ARGS)
07850 (PROG (ACNUM)
07860 (SETQ ACNUM 1)
07870 LOOP (COND ((NULL ARGS) (RETURN NIL)))
07880 (SETSLOT ACNUM (LIST (CAR ARGS)))
07890 (SETQ ACNUM (ADD1 ACNUM))
07900 (SETQ ARGS (CDR ARGS))
07910 (GO LOOP)))
07920
07930 (DFUNC (BOOLAND EXP VALAC TEST)
07940 (PROG2 (BOOLARGS (CDR EXP) (CAR TEST) (CDR TEST) T) (INCR P2CNT)))
07950
07960 (DFUNC (BOOLARGS ARGS FLAG TAG SWITCH)
07970 (PROG (G)
07980 (GUARDLOCS)
07990 (CLEAR1)
08000 (RST TAG)
08010 (PUTPROP (SETQ G (NEXTSYM TAG)) (TOPCOPY PDL) (Q LEVEL))
08020 A (COND ((NULL ARGS) (COND (FLAG (OUTJRST TAG))) (GO C)))
08030 (COND ((AND FLAG (NULL (CDR ARGS))) (GO B)))
08040 (COMPPRED (CAR ARGS)
08050 (CONS (NOT SWITCH) (COND (FLAG G) (T TAG))))
08060 (SETQ ARGS (CDR ARGS))
08070 (GO A)
08080 B (COMPPRED (CAR ARGS) (CONS SWITCH TAG))
08090 (OUTENDTAG G)
08100 C (CLEARBOTH)
08110 (CLEARACS)))
08120
08130
08140 (DFUNC (BOOLEQ EXP VALAC TEST)
08150 (PROG (ARG1 ARG2 LOC1 LOC2 AC MEM TAG F)
08160 (SETQ EXP (CDR EXP))
08170 (COND ((AND (NULL VALAC) (NULL TEST)) (COMPSTAT (CADR EXP))
08180 (COMPSTAT (CADDR EXP))
08190 (RETURN NIL)))
08200 (COND ((OR (NOT (NULL VALAC)) (NULL TEST)) (SETQ F NIL)
08210 (SETQ TAG NIL))
08220 (T (SETQ F (CAR TEST)) (SETQ TAG (CDR TEST))))
08230 (COND ((NOT (EQ (LENGTH EXP) 2)) (USERERR ARGNOERR-BOOLEQ)))
08240 (SETQ ARG1 (COMPEXPR (CAR EXP) (FREEAC)))
08250 (SETQ ARG2 (COMPEXPR (CADR EXP) (FREEAC)))
08260 (SETQ LOC2 (LOC ARG2))
08270 (SETQ LOC1 (LOC ARG1))
08280 (RST TAG)
08290 (COND ((ACNUMP LOC1) (SETQ AC LOC1) (SETQ MEM (LOC ARG2)))
08300 ((ACNUMP LOC2) (SETQ AC LOC2) (SETQ MEM (LOC ARG1)))
08310 (T (LOADARG (SETQ AC (FREEAC)) ARG1)
08320 (SETQ MEM (LOC ARG2))))
08330 (REMOVE ARG1)
08340 (REMOVE ARG2)
08350 (SAVEACS)
08360 (OUT1 (COND (F (Q CAMN)) (T (Q CAME))) AC MEM)
08370 (COND ((NOT (NULL VALAC)) (SETQ AC (BOOLVALUE VALAC TAG))))
08380 (COND ((NOT (NULL TEST)) (OUTJRST (CDR TEST))))
08390 (RETURN AC)))
08400
08410 (DFUNC (BOOLEXPR XPR VALAC TEST)
08420 ((GETPROP (CAR XPR) (Q P2BOOL)) XPR VALAC TEST))
08430
08440 (DFUNC (BOOLNULL EXP VALAC TEST)
08450 (COMPPRED (CADR EXP) (CONS (NOT (CAR TEST)) (CDR TEST))))
08460
08470 (DFUNC (BOOLOR EXP VALAC TEST)
08480 (PROG2 (BOOLARGS (CDR EXP) (NOT (CAR TEST)) (CDR TEST) NIL)
08490 (INCR P2CNT)))
08500
08510 (DFUNC (BOOLVALUE AC TAG)
08520 (PROGN (OUT1 (Q TDZA) AC AC)
08530 (OUTENDTAG TAG)
08540 (OUT1 (Q MOVEI) AC (Q (QUOTE T)))
08550 (MARKVAL AC AC)))
08560
08570
08580 (DFUNC (CALLFSUBR XPR VALAC TEST)
08590 (PROG (FUN ARGS VAL)
08600 (SETQ FUN (CAR XPR))
08610 (SETQ ARGS (CDR XPR))
08620 (CLEARBOTH)
08630 (LOADARG FARGAC (CONS ARGS (Q QT)))
08640 (PROTECTACS FUN)
08650 (SETQ VAL (MARKVAL VALAC VALUEAC))
08660 (OUTCALL 17 FUN)
08670 (RETURN (TESTJUMP VAL TEST))))
08680
08690 (DFUNC (CALLFUNARGS XPR VALAC TEST)
08700 (PROG (FUN ARGS FUNARGS LOCS VAL)
08710 (SETQ FUN (CAR XPR))
08720 (SETQ ARGS (CDR XPR))
08730 (SETQ FUNARGS (COMPEXPR FUN VALUEAC))
08740 (SETQ LOCS (COMPARGS ARGS))
08750 (CLRCCLST LOCS NIL)
08760 (LOADSUBRARGS LOCS)
08770 (CLEARBOTH)
08780 (CLEARACS)
08790 (SETQ VAL (MARKVAL VALAC VALUEAC))
08800 (OUTCALLF (LENGTH LOCS) (LOC FUNARGS))
08810 (REMOVE FUNARGS)
08820 (RETURN (TESTJUMP VAL TEST))))
08830
08840
08850 (DFUNC (CALLLSUBR XPR VALAC TEST)
08860 (PROG (FUN ARGS NARGS HOME INST RETTAG TEM VAL)
08870 (SETQ FUN (CAR XPR))
08880 (SETQ ARGS (CDR XPR))
08890 (CLEAR1)
08900 (SETQ NARGS (LENGTH ARGS))
08910 (SLOTPUSH (Q (NIL . TAKEN)))
08920 (OUTPUSH (GENCONST 0 0 (SETQ RETTAG (NEXTSYM TAG)) 0 0))
08930 LOOP (COND ((NULL ARGS) (GO CALL)))
08940 (SETQ HOME (TOPCOPY PDL))
08950 (SETQ INST (COMPEXPR (CAR ARGS) VALUEAC))
08960 (RESTORE HOME)
08970 (SETQ TEM (LOC INST))
08980 (SLOTPUSH (Q (NIL . TAKEN)))
08990 (OUTPUSH TEM)
09000 (REMOVE INST)
09010 (SETQ ARGS (CDR ARGS))
09020 (GO LOOP)
09030 CALL (SETQ TEM (PDLDEPTH))
09040 (SAVEACS)
09050 (COND ((NOT (EQ (PDLDEPTH) TEM))
09060 (COMPERR PDLTOOLONG-LSUBRCALL)))
09070 (OUTINST (LIST (Q MOVNI) 6 NARGS))
09080 LLOOP(SLOTPOP)
09090 (COND ((ZEROP NARGS) (GO CALL1)))
09100 (SETQ NARGS (SUB1 NARGS))
09110 (GO LLOOP)
09120 CALL1(CLEARBOTH)
09130 (CLEARACS)
09140 (SETQ VAL (MARKVAL VALAC VALUEAC))
09150 (OUTJCALL 16 FUN)
09160 (OUTTAG RETTAG)
09170 (RETURN (TESTJUMP VAL TEST))))
09180
09190
09200 (DFUNC (CALLSUBR XPR VALAC TEST)
09210 (PROG (FUN ARGS NARGS LOCS TEM VAL)
09220 (SETQ FUN (CAR XPR))
09230 (SETQ ARGS (CDR XPR))
09240 (SETQ LOCS (COMPARGS ARGS))
09250 (SETQ NARGS (LENGTH LOCS))
09260 (COND ((AND (SETQ TEM (SEEKPROP FUN (Q COMMU)))
09270 (EQ NARGS 2)
09280 (EQ (ILOC (CAR LOCS) VALUEAC) VALUEAC))
09290 (SETQ LOCS (REVERSE LOCS))
09300 (SETQ FUN (PROPVAL TEM))))
09310 (SETQ TEM (SIDEEFFECTS FUN))
09320 (COND (TEM (CLRCCLST LOCS NIL)))
09330 (LOADSUBRARGS LOCS)
09340 (COND (TEM (CLEARBOTH)))
09350 (PROTECTACS FUN)
09360 (SETQ VAL (MARKVAL VALAC VALUEAC))
09370 (OUTCALL NARGS FUN)
09380 (RETURN (TESTJUMP VAL TEST))))
09390
09400 (DFUNC (CLEAR1) (PROGN (CLEARBOTH) (SAVEACS) (CLRPVARS)))
09410
09420 (DFUNC (CLEARBOTH) (PROGN (CLRCCLST NIL T) (CLRSPLD)))
09430
09440 (DFUNC (CLEARAC ACNO) (PROGN (CPUSH ACNO) (SETSLOT ACNO NIL)))
09450
09460 (DFUNC (CLEARITALL) (PROGN (CLEARBOTH) (CLEARACS)))
09470
09480 (DFUNC (CLEARACS)
09490 (PROG (ACNO)
09500 (SETQ ACNO NACS)
09510 LOOP (COND ((ZEROP ACNO) (RETURN NIL)))
09520 (CLEARAC ACNO)
09530 (SETQ ACNO (SUB1 ACNO))
09540 (GO LOOP)))
09550
09560 (DFUNC (CLRCCLST DATA FL)
09570 (PROG (CCL)
09580 (SETQ CCL CCLST)
09590 LOOP (COND ((NULL CCL) (COND (FL (SETQ CCLST NIL))) (RETURN NIL)))
09600 (COND ((ASSOC (CAAR CCL) DATA) (GO ELOOP)))
09610 (CSFUN (CAR CCL) VALUEAC)
09620 ELOOP(SETQ CCL (CDR CCL))
09630 (GO LOOP)))
09640
09650
09660 (DFUNC (CLRPVARS)
09670 (PROG NIL
09680 (COND ((NOT PROGSW) (RETURN NIL)))
09690 (SETQ PROGSW NIL)
09700 LOOP (COND ((NULL PROGVARS) (SETQ PRSSL (TOPCOPY PDL))
09710 (SETQ MINDEPTH (PDLDEPTH))
09720 (RETURN NIL))
09730 ((NOT (ILOC (CONS (CAR PROGVARS) P2CNT) VALUEAC))
09740 (INITZ (CAR PROGVARS))))
09750 (SETQ PROGVARS (CDR PROGVARS))
09760 (GO LOOP)))
09770
09780 (DFUNC (CLRSPLD)
09790 (PROG (LDL)
09800 (SETQ LDL LDLST)
09810 LOOP (COND ((NULL LDL) (RETURN NIL)))
09820 (COND ((SPECVARP (CAAR LDL)) (CLRSPVAR (CAR LDL))))
09830 (SETQ LDL (CDR LDL))
09840 (GO LOOP)))
09850
09860 (DFUNC (CLRSPVAR L)
09870 (PROG (LOC)
09880 (SETQ LOC (ILOC L VALUEAC))
09890 (COND ((NOT (NUMBERP LOC))
09900 (SLOTPUSH (CONS (CAR L) P2CNT))
09910 (OUTPUSH (LIST (Q SPECIAL) (CAR L))))
09920 ((ACNUMP LOC) (SLOTPUSH (SLOTCONT LOC)) (OUTPUSH LOC)))
09930 (RETURN NIL)))
09940
09950 (DFUNC (COMPARGS ARGS)
09960 (PROG (ARGNO RESULT)
09970 (SETQ ARGNO 0)
09980 LOOP (COND ((NULL ARGS) (RETURN RESULT)))
09990 (SETQ ARGNO (ADD1 ARGNO))
10000 (SETQ RESULT (CONS (COMPEXPR (CAR ARGS) ARGNO) RESULT))
10010 (SETQ ARGS (CDR ARGS))
10020 (GO LOOP)))
10030
10040 (DFUNC (COMPEXPR XPR VALAC) (COMPFORM XPR VALAC NIL))
10050
10060 (DFUNC (COMPPRED XPR TEST) (COMPFORM XPR NIL TEST))
10070
10080
10090 (DFUNC (COMPFORM XPR VALAC TEST)
10100 (PROG (TEM)
10110 (COND ((ATOM XPR) (GO ATOM)))
10120 (COND ((ATOM (CAR XPR)) (GO ATOMC)))
10130 (COND ((EQ (CAAR XPR) (Q LAMBDA))
10140 (RETURN (INTERNALLAMBDA XPR VALAC TEST))))
10150 (RETURN (CALLFUNARGS XPR VALAC TEST))
10160 ATOM (SETQ TEM (CONS XPR (INCR P2CNT)))
10170 (COND ((NOT (NULL VALAC)) (SETQ LDLST (CONS TEM LDLST))))
10180 (RETURN (TESTJUMP TEM TEST))
10190 ATOMC(COND ((SETQ TEM (GETGET (CAR XPR) (Q PASS2)))
10200 (RETURN ((PROPVAL TEM) XPR VALAC TEST))))
10210 (COND ((OR (SPECVARP (CAR XPR)) (ASSOC (CAR XPR) LOCVARS))
10220 (RETURN (CALLFUNARGS XPR VALAC TEST))))
10230 (COMPERR UNKNOWNFUNCTION-COMPFORM)))
10240
10250 (DFUNC (COMPSTAT XPR) (COMPFORM XPR NIL NIL))
10260
10270 (DFUNC (COPT FUN AC ARGLOC)
10280 (PROG (CCL TEM YLOC)
10290 (SETQ YLOC (ILOC ARGLOC AC))
10300 (SETQ CCL CCLST)
10310 LOOP (COND ((NULL CCL) (RETURN NIL))
10320 ((AND (EQ FUN (CADAR CCL))
10330 (EQUAL (ILOC (CDDAR CCL) AC) YLOC)
10340 (ILOC (SETQ TEM (LIST (CAAR CCL))) AC))
10350 (RETURN TEM)))
10360 (SETQ CCL (CDR CCL))
10370 (GO LOOP)))
10380
10390
10400 (DFUNC (CPUSH ACNO)
10410 (PROG (TEMPDL SLOTNO SLOTCON HOLDSLOT)
10420 (COND ((NOT (DVP (SETQ SLOTCON (SLOTCONT ACNO))))
10430 (RETURN NIL)))
10440 (COND ((LESSP ACNO 1) (GO MAKE)))
10450 START(SETQ SLOTNO 0)
10460 (SETQ TEMPDL PDL)
10470 LOOP (COND ((NULL TEMPDL) (GO NONE)))
10480 (COND ((DVP (CAR TEMPDL)) (GO ELOOP)))
10490 (COND ((OR (NOT (NUMBERP (CDAR TEMPDL)))
10500 (SPECVARP (CAAR TEMPDL)))
10510 (SETQ HOLDSLOT SLOTNO)))
10520 (COND ((EQ (CAR SLOTCON) (CAAR TEMPDL)) (GO FOUND)))
10530 ELOOP(SETQ TEMPDL (CDR TEMPDL))
10540 (SETQ SLOTNO (SUB1 SLOTNO))
10550 (GO LOOP)
10560 FOUND(SETSLOT SLOTNO SLOTCON)
10570 (COND ((NULL (CDR SLOTCON))
10580 (SETSLOT ACNO (CONS (CAR SLOTCON) (Q DUP)))))
10590 (OUTMOVEM ACNO SLOTNO)
10600 (RETURN NIL)
10610 NONE (COND (HOLDSLOT (SETQ SLOTNO HOLDSLOT) (GO FOUND)))
10620 MAKE (COND ((AND PROGSW (NOT (ASSOC (CAR SLOTCON) LOCVARS)))
10630 (SETQ TEMPDL (PDLDEPTH))
10640 (CLRPVARS)
10650 (COND ((LESSP ACNO 1)
10660 (SETQ ACNO (PLUS ACNO
10670 (DIFFERENCE TEMPDL
10680 (PDLDEPTH))))))))
10690 (SLOTPUSH SLOTCON)
10700 (SETSLOT ACNO
10710 (COND ((NULL (CDR SLOTCON))
10720 (CONS (CAR SLOTCON) (Q DUP)))
10730 (T NIL)))
10740 (OUTPUSH ACNO)
10750 (RETURN NIL)))
10760
10770 (DFUNC (CSFUN L AC)
10780 (PROG (Y)
10790 (COND ((AND (SETQ Y (ASSOC (CAR L) LDLST)) (NOT (ILOC Y AC)))
10800 (LOADCARCDR L AC)))))
10810
10820 (DFUNC (CSTEP FUN AC ARGLOC)
10830 (PROG (TEM)
10840 (COND ((NULL FUN) (RETURN (LIST ARGLOC))))
10850 (COND ((SETQ TEM (COPT FUN AC ARGLOC)) (RETURN (LIST TEM))))
10860 (RETURN (CONS (CAR (SETQ TEM (GETPROP FUN (Q CARCDR))))
10870 (CSTEP (CDR TEM) AC ARGLOC)))))
10880
10890
10900 (DFUNC (DOP2BOOL XPR VALAC TEST)
10910 (PROG (TG)
10920 (CLEARBOTH)
10930 (PUTPROP (SETQ TG (NEXTSYM TAG)) T (Q SET))
10940 (COND ((NOT (NULL VALAC))
10950 (RETURN (PROG (CTAG RSL)
10960 (BOOLEXPR XPR VALAC (CONS T TG))
10970 (RETURN (TESTJUMP (BOOLVALUE VALAC TG)
10980 TEST))))))
10990 (BOOLEXPR XPR VALAC (COND ((NULL TEST) (CONS T TG)) (T TEST)))
11000 (COND ((NULL TEST) (OUTENDTAG TG)))))
11010
11020 (DFUNC (DOP2ELSE XPR VALAC TEST)
11030 ((GETPROP (CAR XPR) (Q P2ELSE)) XPR VALAC TEST))
11040
11050 (DFUNC (DOP2VAL XPR VALAC TEST)
11060 (TESTJUMP ((GETPROP (CAR XPR) (Q P2VAL)) XPR VALAC TEST) TEST))
11070
11080 (DFUNC (DVP X)
11090 (PROG (Y Z)
11100 (COND ((NULL X) (RETURN NIL)))
11110 (COND ((EQ (CDR X) (Q QT)) (RETURN NIL)))
11120 (COND ((EQ (CDR X) (Q DUP)) (RETURN NIL)))
11130 (COND ((EQ (CDR X) (Q TAKEN)) (RETURN T)))
11140 (COND ((AND (SPECVARP (CAR X)) (NULL (CDR X))) (RETURN NIL)))
11150 (COND ((AND (SETQ Y (ASSOC (CAR X) LOCVARS))
11160 (NULL (CDR X))
11170 (LESSP P2CNT (CDR Y)))
11180 (RETURN T)))
11190 (SETQ Z LDLST)
11200 LOOP (COND ((NULL Z)
11210 (RETURN (COND ((SETQ Z (ASSOC (CAR X) VARLIST))
11220 (DVP (CONS (CDR Z) (CDR X))))
11230 (T NIL)))))
11240 (COND ((AND (EQ (CAAR Z) (CAR X))
11250 (EQUAL (LOC (COND ((NUMBERP (CDR X)) X)
11260 (T (CONS (CAR X) P2CNT))))
11270 (LOC (CAR Z))))
11280 (RETURN T)))
11290 (SETQ Z (CDR Z))
11300 (GO LOOP)))
11310
11320 (DFUNC (EQUIVTAG PTAG)
11330 (PROG (LTAG)
11340 (COND ((SETQ LTAG (ASSOC PTAG GOLIST)) (RETURN (CDR LTAG))))
11350 (USERWARN PTAG UNDEFINED TAG)
11360 (RETURN EXIT)))
11370
11380
11390 (DFUNC (EXITBUM SPECFLAG)
11400 (PROG (TEM1 TEM2)
11410 (COND ((SETQ TEM1 (ASSOC (CAAR LASTOUT)
11420 (Q ((CALL JCALL) (PUSHJ JRST)))))
11430 (SETQ TEM2 (CAR LASTOUT))
11440 (SETQ LASTOUT NIL)
11450 (KILLPDL)
11460 (OUTINST TEM2)
11470 (COND ((NOT SPECFLAG)
11480 (SETQ TEM2 (CAR LASTOUT))
11490 (SETQ LASTOUT NIL)
11500 (OUTINST (MCONS (CADR TEM1)
11510 (SUBST 0 (Q P) (CADR TEM2))
11520 (CDDR TEM2)))
11530 (RETURN NIL)))))
11540 (KILLPDL)
11550 (COND (SPECFLAG (OUTINST (Q (JRST 0 SPECSTR))))
11560 (T (OUTINST (Q (POPJ P)))))))
11570
11580 (DFUNC (FREEAC) (FREEAC1 VALUEAC))
11590
11600 (DFUNC (FREEAC1 BEST)
11610 (PROG (ACNO ACCS)
11620 (COND ((AND (NOT (NULL BEST)) (NOT (DVP (SLOTCONT BEST))))
11630 (RETURN BEST)))
11640 (SETQ ACCS ACS)
11650 (SETQ ACNO 1)
11660 LOOP (COND ((NULL ACCS) (COND ((NULL BEST) (RETURN NIL))
11670 (T (CPUSH BEST) (RETURN BEST)))))
11680 (COND ((NOT (DVP (CAR ACCS))) (RETURN ACNO)))
11690 (SETQ ACCS (CDR ACCS))
11700 (SETQ ACNO (ADD1 ACNO))
11710 (GO LOOP)))
11720
11730 (DFUNC (FINDFREEAC) (FREEAC1 NIL))
11740
11750 (DFUNC (FREEZE VAR) (PROGN (FREEZE1 VAR ACS) (FREEZE1 VAR PDL)))
11760
11770 (DFUNC (FREEZE1 X Z)
11780 (PROG NIL
11790 LOOP (COND ((NULL Z) (RETURN NIL)))
11800 (COND ((EQ X (CAAR Z))
11810 (COND ((NULL (CDAR Z)) (RPLACA Z (CONS X P2CNT)))
11820 ((EQ (CDAR Z) (Q DUP)) (RPLACA Z NIL)))))
11830 (SETQ Z (CDR Z))
11840 (GO LOOP)))
11850
11860
11870 (DFUNC (GENCONST OP AC AD IN IB)
11880 (PROG (ANS)
11890 (COND ((NOT (ZEROP IB)) (SETQ ANS (LIST *AT))))
11900 (SETQ ANS (APPEND ANS (LIST AC AD IN)))
11910 (SETQ ANS (CONS OP ANS))
11920 (RETURN (CONS (Q C) ANS))))
11930
11940 (DFUNC (GETSLOT NO)
11950 (COND ((NOT (NUMBERP NO)) (COMPERR NOTSLOT-GETSLOT))
11960 ((GREATERP NO NACS) (PRINTMSG NO) (COMPERR NOTAC-GETSLOT))
11970 ((GREATERP NO 0) (NTHCDR (SUB1 NO) ACS))
11980 ((GREATERP (ABS NO) (PDLDEPTH)) (PRINTMSG NO)
11990 (COMPERR NOTONPDL-GETSLOT))
12000 ((NTHCDR (MINUS NO) PDL))))
12010
12020 (DFUNC (GUARDLOCS)
12030 (PROG (LDL VARLOC LOCCONT)
12040 (SETQ LDL LDLST)
12050 LOOP (COND ((NULL LDL) (RETURN NIL)))
12060 (COND ((ASSOC (CAAR LDL) LOCVARS) (GO ISVAR)))
12070 ELOOP(SETQ LDL (CDR LDL))
12080 (GO LOOP)
12090 ISVAR(SETQ VARLOC (LOC (CAR LDL)))
12100 (COND ((NOT (NUMBERP VARLOC)) (GO PUSH)))
12110 (SETQ LOCCONT (SLOTCONT VARLOC))
12120 (COND ((NOT (DVP LOCCONT))
12130 (SETSLOT VARLOC (CONS (CAAR LDL) P2CNT))
12140 (GO ELOOP))
12150 ((NUMBERP (CDR LOCCONT)) (GO ELOOP)))
12160 PUSH (SLOTPUSH (CONS (CAAR LDL) P2CNT))
12170 (OUTPUSH VARLOC)
12180 (GO ELOOP)))
12190
12200
12210 (DFUNC (ILOC X AC)
12220 (PROG (CNTR BEST BESTNO SL SLOT CNT XCNT)
12230 (COND ((NULL AC) (GO LOOK)))
12240 (COND ((EQUAL X (SLOTCONT AC)) (RETURN AC)))
12250 LOOK (COND ((EQ (CDR X) (Q QT))
12260 (RETURN (LIST (LIST (Q QUOTE) (CAR X))))))
12270 (SETQ SL (APPEND ACS PDL))
12280 (SETQ CNTR 1)
12290 (SETQ BESTNO (ADD1 P2CNT))
12300 (SETQ XCNT (COND ((NUMBERP (CDR X)) (CDR X)) (T P2CNT)))
12310 LOOP (COND ((NULL SL) (GO EXIT)))
12320 (SETQ SLOT (CAR SL))
12330 (COND ((AND SLOT (EQ (CAR X) (CAR SLOT))) (GO ISONE)))
12340 ELOOP(SETQ SL (CDR SL))
12350 (SETQ CNTR (ADD1 CNTR))
12360 (GO LOOP)
12370 EXIT (COND ((NOT (GREATERP BESTNO P2CNT)) (GO RETN)))
12380 (COND ((SPECVARP (CAR X))
12390 (RETURN (LIST (Q SPECIAL) (CAR X)))))
12400 (RETURN NIL)
12410 ISONE(COND ((OR (EQUAL X SLOT)
12420 (NOT (MEMQ (CDR SLOT) (Q (QT TAKEN)))))
12430 (SETQ CNT (COND ((NUMBERP (CDR SLOT)) (CDR SLOT))
12440 (T P2CNT)))
12450 (COND ((AND (NOT (LESSP CNT XCNT)) (LESSP CNT BESTNO))
12460 (SETQ BESTNO CNT)
12470 (SETQ BEST CNTR)))))
12480 (GO ELOOP)
12490 RETN (RETURN (COND ((NOT (GREATERP BEST NACS)) BEST)
12500 (T (PLUS (MINUS BEST) NACS 1))))))
12510
12520 (DFUNC (ILOC1 X AC)
12530 (PROG (Z)
12540 (COND ((SETQ Z (ILOC X AC)) (RETURN Z)))
12550 (COND ((MEMBER (CAR X) PROGVARS) (RETURN (Q ((QUOTE NIL))))))
12560 (COND ((SETQ Z (ASSOCR (CAR X) VARLIST))
12570 (RETURN (ILOC1 (CONS (CAR Z) (CDR X)) AC))))
12580 (COND ((SETQ Z (ASSOC (CAR X) CCLST))
12590 (RETURN (LOADCARCDR Z
12600 (COND ((NULL AC) (FREEAC))
12610 (T AC))))))
12620 (PRINTMSG (LIST X))
12630 (COMPERR LOSTVAR-ILOC1)))
12640
12650 (DFUNC (INITZ X)
12660 (PROGN (SLOTPUSH (LIST X)) (OUTPUSH (Q ((QUOTE NIL))))))
12670
12680
12690 (DFUNC (INTERNALLAMBDA XPR VALAC TEST)
12700 (PROG (BODY ARGS SF VARS VAL LOC SAVCNT TEM)
12710 (SETQ BODY (CADDAR XPR))
12720 (SETQ VARS (CADAR XPR))
12730 (SETQ ARGS (REVERSE (COMPARGS (CDR XPR))))
12740 (SETQ SAVCNT P2CNT)
12750 (INCR P2CNT)
12760 A (COND ((NULL VARS) (GO B)))
12770 (SETQ LOC (LOC (CAR ARGS)))
12780 (REMOVE (CAR ARGS))
12790 (COND ((SPECVARP (CAR VARS))
12800 (SETQ SF T)
12810 (FREEZE (CAR VARS))
12820 (SETQ LOC (PUTINAC (CAR ARGS) (FREEAC))))
12830 ((OR (NOT (NUMBERP LOC)) (DVP (SETQ TEM (SLOTCONT LOC))))
12840 (SLOTPUSH TEM)
12850 (COND ((NULL (CDR TEM))
12860 (SETSLOT LOC (CONS (CAR TEM) (Q DUP)))))
12870 (OUTPUSH LOC)
12880 (SETQ LOC 0)))
12890 (SETSLOT LOC (CONS (CAR VARS) (Q TAKEN)))
12900 (SETQ ARGS (CDR ARGS))
12910 (SETQ VARS (CDR VARS))
12920 (GO A)
12930 B (COND (SF (OUTINST (Q (JSP 6 SPECBIND)))))
12940 (SETQ VARS (CADAR XPR))
12950 C (COND ((NULL VARS) (GO D)))
12960 (SETQ LOC (ILOC (CONS (CAR VARS) (Q TAKEN)) NIL))
12970 (COND ((SPECVARP (CAR VARS))
12980 (OUTINST (LIST 0 LOC (LIST (Q SPECIAL) (CAR VARS))))))
12990 (RPLACD (SLOTCONT LOC) NIL)
13000 (SETQ VARS (CDR VARS))
13010 (GO C)
13020 D (SETQ TEM (COMPEXPR BODY VALAC))
13030 (SETQ LOC (LOC TEM))
13040 (SETQ VAL (MARKVAL VALAC
13050 (COND ((NUMBERP LOC) LOC)
13060 (T (PUTINAC TEM (FREEAC))))))
13070 (REMOVE TEM)
13080 (COND (SF (OUTINST (Q (PUSHJ P SPECSTR)))))
13090 (INCR P2CNT)
13100 (SETQ VARS (CADAR XPR))
13110 (INTLAM1 ACS VARS SAVCNT)
13120 (INTLAM1 PDL VARS SAVCNT)
13130 (RETURN (TESTJUMP VAL TEST))))
13140
13150
13160 (DFUNC (INTLAM1 LST VARS CNT)
13170 (PROG NIL
13180 LOOP (COND ((NULL LST) (RETURN NIL)))
13190 (COND ((AND (NOT (NULL (CAR LST)))
13200 (SPECVARP (CAAR LST))
13210 (MEMQ (CAAR LST) VARS)
13220 (OR (NULL (CDAR LST))
13230 (GREATERP (CDAR LST) CNT)))
13240 (RPLACA LST NIL)))
13250 (SETQ LST (CDR LST))
13260 (GO LOOP)))
13270
13280 (DFUNC (KILLPDL) (RESTORE NIL))
13290
13300 (DFUNC (LISTNILS NUMBER)
13310 (PROG (LIST)
13320 LOOP (COND ((ZEROP NUMBER) (RETURN LIST)))
13330 (SETQ LIST (CONS NIL LIST))
13340 (SETQ NUMBER (SUB1 NUMBER))
13350 (GO LOOP)))
13360
13370
13380 (DFUNC (LOADARG ACNO VAR)
13390 (PROG (DATAORG OLDACC DATACONT DAC DOD)
13400 (REMOVE VAR)
13410 (COND ((NULL ACNO) (RETURN NIL)))
13420 (SETQ DATAORG (ILOC1 VAR ACNO))
13430 (SETQ OLDACC (SLOTCONT ACNO))
13440 (SETQ DATACONT (COND ((NUMBERP DATAORG) (SLOTCONT DATAORG))))
13450 (SETQ DAC (DVP OLDACC))
13460 (SETQ DOD (DVP DATACONT))
13470 (COND ((EQ ACNO DATAORG) (COND (DAC (CPUSH ACNO)))
13480 (RETURN NIL)))
13490 (COND ((AND (EQ DATAORG 0)
13500 (NOT DOD)
13510 (NOT DAC)
13520 (GREATERP (PDLDEPTH) MINDEPTH))
13530 (GO POP)))
13540 (COND ((AND (NOT DOD)
13550 (NOT (NULL OLDACC))
13560 (NUMBERP DATAORG)
13570 (LESSP DATAORG ACNO))
13580 (GO EXCH)))
13590 (COND ((NOT DAC) (GO FREE)))
13600 (GO PUSH)
13610 EXCH (SETSLOT DATAORG OLDACC)
13620 (SETSLOT ACNO DATACONT)
13630 (OUT1 (Q EXCH) ACNO DATAORG)
13640 (RETURN NIL)
13650 PUSH (CPUSH ACNO)
13660 (SETQ DATAORG (LOC VAR))
13670 FREE (COND ((NOT (NUMBERP DATAORG)) (GO MOVE)))
13680 (SETSLOT ACNO
13690 (COND ((NULL (CDR DATACONT))
13700 (CONS (CAR DATACONT) (Q DUP)))
13710 (T DATACONT)))
13720 (OUTMOVE ACNO DATAORG)
13730 (RETURN NIL)
13740 POP (SETSLOT ACNO DATACONT)
13750 (OUTPOP ACNO)
13760 (RETURN NIL)
13770 MOVE (SETSLOT ACNO
13780 (COND ((EQ (CAAR DATAORG) (Q QUOTE))
13790 (CONS (CADAR DATAORG) (Q QT)))
13800 (T (LIST (CAR VAR)))))
13810 (OUTMOVE ACNO DATAORG)
13820 (RETURN NIL)))
13830
13840
13850 (DFUNC (LOADCARCDR ITEM AC)
13860 (PROG (ARG PATH ORIG)
13870 (COND ((EQ (ILOC1 (SETQ ARG (CDDR ITEM)) AC) AC)
13880 (REMOVE ARG)))
13890 (SETQ PATH (CSTEP (CADR ITEM) AC ARG))
13900 (COND ((NULL (CDR PATH))
13910 (SETQ VARLIST (CONS (CONS (CAR (CAR PATH)) (CAR ITEM))
13920 VARLIST))
13930 (REMOVE ARG)
13940 (RETURN (LOC (CAR PATH)))))
13950 (SETQ PATH (REVERSE PATH))
13960 (CPUSH AC)
13970 (SETQ ORIG (LOC (CAR PATH)))
13980 (SETQ PATH (CDR PATH))
13990 (REMOVE ARG)
14000 L1 (COND ((NULL PATH) (GO RET)))
14010 (COND ((NULL (CDR PATH)) (GO L2)))
14020 (COND ((AND (EQ AC VALUEAC) (EQ ORIG VALUEAC))
14030 (OUTCALL 1
14040 (READLIST (CONS (Q C)
14050 (REVERSE (CONS (Q R) PATH)))))
14060 (GO RET)))
14070 L2 (OUT1 (CADR (ASSOC (CAR PATH) (Q ((A HLRZ@) (D HRRZ@)))))
14080 AC
14090 ORIG)
14100 (SETQ PATH (CDR PATH))
14110 (SETQ ORIG AC)
14120 (GO L1)
14130 RET (SETSLOT AC (LIST (CAR ITEM)))
14140 (RETURN AC)))
14150
14160 (DFUNC (LOADCOMP XPR AC) (LOADARG AC (COMPEXPR XPR AC)))
14170
14180 (DFUNC (LOADSUBRARGS ARGS)
14190 (PROG (ARGNO)
14200 (SETQ ARGNO (LENGTH ARGS))
14210 LOOP (COND ((NULL ARGS) (RETURN NIL)))
14220 (LOADARG ARGNO (CAR ARGS))
14230 (SETQ ARGS (CDR ARGS))
14240 (SETQ ARGNO (SUB1 ARGNO))
14250 (GO LOOP)))
14260
14270 (DFUNC (LOC X) (ILOC1 X NIL))
14280
14290 (DFUNC (MARKVAL FLAG LOC)
14300 (PROG (VAR GVAL)
14310 (COND ((NULL LOC) (RETURN NIL)))
14320 (SETQ GVAL (NEXTSYM VAL))
14330 (SETQ VAR (CAR (SETSLOT LOC (LIST GVAL))))
14340 (COND ((NOT (NULL FLAG)) (SETQ LDLST (CONS VAR LDLST))))
14350 (RETURN VAR)))
14360
14370
14380 (DFUNC (NONSPECVARS VRS)
14390 (PROG (ANS)
14400 LOOP (COND ((NULL VRS) (RETURN ANS))
14410 ((SPECVARP (CAR VRS)))
14420 (T (SETQ ANS (CONS (CAR VRS) ANS))))
14430 (SETQ VRS (CDR VRS))
14440 (GO LOOP)))
14450
14460 (DFUNC (OUT1 OP AC AD) (OUTINST (TRANSOUT OP AC AD)))
14470
14480 (DFUNC (OUTCALL NUM FUN) (OUTFUNCALL (Q CALL) NUM FUN))
14490
14500 (DFUNC (OUTCALLF AC AD) (OUT1 (Q CALLF@) AC AD))
14510
14520 (DFUNC (OUTCJMP FLAG AC ADRESS)
14530 (OUTJMP (COND (FLAG (Q JUMPN)) (T (Q JUMPE))) AC ADRESS))
14540
14550 (DFUNC (OUTENDTAG X)
14560 (COND ((USEDTAGP X) (CLEARITALL) (RST X) (OUTTAG X))))
14570
14580 (DFUNC (OUTFUNCALL TYPE NUM FUN)
14590 (OUTINST (LIST TYPE NUM (LIST (Q E) FUN))))
14600
14610 (DFUNC (OUTGOTAB X)
14620 (PROG (ETAG)
14630 (SETQ ETAG (NEXTSYM TAG))
14640 (PUTPROP ETAG (TOPCOPY PDL) (Q LEVEL))
14650 (COND ((NOT (EQ (CAAR LASTOUT) (Q JRST))) (OUTJRST ETAG)))
14660 (OUTTAG (CAR X))
14670 LOOP (SETQ X (CDR X))
14680 (COND ((NULL X) (OUTINST (Q (PUSHJ P *UDT)))
14690 (OUTTAG ETAG)
14700 (RETURN NIL)))
14710 (OUTINST (LIST (Q CAIN) GOTABAC (LIST (Q QUOTE) (CAAR X))))
14720 (OUTJRST (CDAR X))
14730 (GO LOOP)))
14740
14750 (DFUNC (OUTJCALL NUM FUN) (OUTFUNCALL (Q JCALL) NUM FUN))
14760
14770 (DFUNC (OUTJMP OP AC ADR)
14780 (PROGN (SAVEACS)
14790 (CLEARBOTH)
14800 (RST ADR)
14810 (PUTPROP ADR T (Q USED))
14820 (OUTINST (LIST OP AC ADR))))
14830
14840 (DFUNC (OUTJRST ADR) (OUTJMP (Q JRST) 0 ADR))
14850
14860 (DFUNC (OUTMOVE AC MEM) (OUT1 (Q MOVE) AC MEM))
14870
14880 (DFUNC (OUTMOVEM AC MEM) (OUT1 (Q MOVEM) AC MEM))
14890
14900
14910 (DFUNC (OUTPOP L) (PROG2 (SLOTPOP) (OUT1 (Q POP) (Q P) L)))
14920
14930 (DFUNC (OUTPUSH L) (OUT1 (Q PUSH) (Q P) L))
14940
14950 (DFUNC (OUTPUTSTAT ST)
14960 (PROG (ADD)
14970 (COND ((ATOM ST) (GO PRINT)))
14980 (COND ((EQ (CAR ST) (Q LAP)) (GO PRINT)))
14990 (SETQ CODESIZE (ADD1 CODESIZE))
15000 (SETQ ADD (CADDR ST))
15010 (COND ((AND (NOT (ATOM ADD)) (EQ (CAR ADD) (Q C)))
15020 (SETQ CONSTSIZE (ADD1 CONSTSIZE))))
15030 PRINT(PRINTSTAT ST)))
15040
15050 (DFUNC (OUTSTAT ST)
15060 (PROG (COL EXPRS)
15070 (COND ((NULL LASTOUT) (GO SETIT)))
15080 (OUTPUTSTAT (CAR LASTOUT))
15090 (SETQ COL (CURCOL))
15100 (SETQ EXPRS (CDR LASTOUT))
15110 TRACE(COND ((NULL EXPRS) (GO SETIT)))
15120 (TABTO COL)
15130 (PRINTEXPR (CAR EXPRS))
15140 (SETQ EXPRS (CDR EXPRS))
15150 (GO TRACE)
15160 SETIT(SETQ LASTOUT (CONS ST (LAPNOTES)))
15170 (RETURN NIL)))
15180
15190 (DFUNC (P2*EVAL XPR VALAC TEST)
15200 (PROG (ARG TEM VAL)
15210 (SETQ ARG (CADR XPR))
15220 (COND ((AND (EQ (CAR ARG) (Q CONS))
15230 (EQ (CAADR ARG) (Q QUOTE))
15240 (GETL (SETQ TEM (CADADR ARG))
15250 (Q (FEXPR FSUBR *FSUBR))))
15260 (GO NOCONS)))
15270 (RETURN (CALLSUBR XPR VALAC TEST))
15280 NOCONS
15290 (LOADCOMP (CADDR ARG) VALUEAC)
15300 (PROTECTACS TEM)
15310 (SETQ VAL (MARKVAL (NOT (NULL VALAC)) VALUEAC))
15320 (OUTINST (LIST (Q CALL) 17 (LIST (Q E) TEM)))
15330 (RETURN VAL)))
15340
15350
15360 (DFUNC (P2ARG XPR VALAC TEST)
15370 (PROG (ARG)
15380 (SETQ ARG (COMPEXPR (CADR XPR) VALAC))
15390 (COND ((EQ (CDR ARG) (Q QT))
15400 (CPUSH VALAC)
15410 (OUTMOVE VALAC (MINUS (ADD1 (PDLDEPTH))))
15420 (REMOVE ARG)
15430 (OUTINST (LIST (Q HRRZ) VALAC (CADR ARG) VALAC))
15440 (RETURN (MARKVAL (NOT (NULL VALAC)) VALAC))))
15450 (LOADARG VALAC ARG)
15460 (OUT1 (Q ADD) VALAC (MINUS (ADD1 (PDLDEPTH))))
15470 (OUTINST (LIST (Q HRRZ) VALAC (MINUS INUM0) VALAC))
15480 (RETURN (MARKVAL (NOT (NULL VALAC)) VALAC))))
15490
15500 (DFUNC (P2CARCDR XPR VALAC TEST)
15510 (PROG (TEM AC)
15520 (COND ((NOT (EQ (LENGTH (CDR XPR)) 1))
15530 (USERERR ARGNOERR-P2CARCDR)))
15540 (COND ((AND (NULL VALAC) (NULL TEST))
15550 (RETURN (COMPSTAT (CADR XPR)))))
15560 (SETQ AC (COND ((NULL VALAC) (FREEAC)) (T VALAC)))
15570 (SETQ XPR (CONS (SETQ TEM (GENSYM))
15580 (CONS (CAR XPR) (COMPEXPR (CADR XPR) AC))))
15590 (SETQ CCLST (CONS XPR CCLST))
15600 (SETQ TEM (LIST TEM))
15610 (COND ((NOT (NULL VALAC)) (SETQ LDLST (CONS TEM LDLST))))
15620 (RETURN (TESTJUMP TEM TEST))))
15630
15640 (DFUNC (P2COND XPR VALAC TEST)
15650 (PROG (AC CTAG RSL VALF)
15660 (GUARDLOCS)
15670 (CLEAR1)
15680 (SETQ VALF (OR (NOT (NULL VALAC)) (NOT (NULL TEST))))
15690 (SETQ AC (COND ((NULL VALAC) (FREEAC)) (T VALAC)))
15700 (P2COND1 (CDR XPR) VALF AC MINDEPTH)
15710 (INCR P2CNT)
15720 (INCR P2CNT)
15730 (RETURN (MARKVAL VALF AC))))
15740
15750
15760 (DFUNC (P2COND1 ARGS VALF AC MINDEPTH)
15770 (PROG (CONDEXIT PAIREXIT H1 H2 RETNIL IRSSL ACNIL PAIR ATAG REST)
15780 (SETQ CONDEXIT (NEXTSYM TAG))
15790 (SETQ IRSSL (TOPCOPY PDL))
15800 (SETQ MINDEPTH (PDLDEPTH))
15810 (PUTPROP CONDEXIT IRSSL (Q LEVEL))
15820 LOOP (SETQ RSL NIL)
15830 (COND ((NULL ARGS) (COND (RETNIL (LOADARG AC (Q (NIL . QT)))))
15840 (OUTENDTAG CONDEXIT)
15850 (COND ((USEDTAGP PAIREXIT) (CLEARITALL)))
15860 (RESTORE IRSSL)
15870 (RETURN NIL)))
15880 (SETQ PAIR (CAR ARGS))
15890 (COND ((NULL (CDR PAIR))
15900 (LOADCOMP (CAR PAIR) AC)
15910 (COND ((NOT (NULL (CDR ARGS))) (OUTCJMP T AC CONDEXIT))
15920 (T (RESTORE IRSSL)))
15930 (GO NONIL)))
15940 (COND ((AND (EQUAL (CDR PAIR) (Q ((QUOTE NIL))))
15950 (EQ (CAAR PAIR) (Q NULL))
15960 (OR (ATOM (CADAR PAIR))
15970 (NOT (HASPROP (CAADAR PAIR) (Q BOOL)))))
15980 (LOADCOMP (CADAR PAIR) AC)
15990 (OUTCJMP NIL AC CONDEXIT)
16000 (SETQ RETNIL T)
16010 (GO ELOOP)))
16020 (COND ((OR LDLST (NOT (NULL (CDDR PAIR)))) (GO L2)))
16030 (COND ((AND (EQ (CAADR PAIR) (Q GO))
16040 (ATOM (SETQ ATAG (CADADR PAIR))))
16050 (COMPPRED (CAR PAIR) (CONS T (EQUIVTAG ATAG)))
16060 (GO NONIL)))
16070 (COND ((EQUAL (CADR PAIR) (Q (RETURN (QUOTE NIL))))
16080 (COMPPRED (CAR PAIR) (CONS T EXITN))
16090 (GO NONIL)))
16100 L2 (SETQ PAIREXIT (SETQ CTAG (NEXTSYM TAG)))
16110 (PUTPROP PAIREXIT IRSSL (Q LEVEL))
16120 (SETQ RSL NIL)
16130 (COMPPRED (CAR PAIR) (CONS NIL PAIREXIT))
16140 (SETQ H2 (COND ((NOT (ATOM RSL)) RSL)
16150 (T (LIST (TOPCOPY ACS) (TOPCOPY PDL)))))
16160 (SETQ H1 (TOPCOPY CCLST))
16170 (SETQ REST (CDR PAIR))
16180 LP1 (COND ((NULL (CDR REST)) (GO L1)))
16190 (COMPSTAT (CAR REST))
16200 (SETQ REST (CDR REST))
16210 (GO LP1)
16220 L1 (COND ((NULL VALF) (COMPSTAT (CAR REST)))
16230 (T (LOADCOMP (CAR REST) AC)))
16240 (SAVEACS)
16250 (SETQ CCLST H1)
16260 (SETQ H1 ACS)
16270 (SETQ ACS (CAR H2))
16280 (SETQ ACNIL (EQUAL (SLOTCONT AC) (Q (NIL . QT))))
16290 (SETQ ACS H1)
16300 (SETQ RETNIL NIL)
16310 (COND ((NOT (MEMQ (CAAR REST) (Q (GO RETURN))))
16320 (COND ((OR (NOT (NULL (CDR ARGS)))
16330 (AND VALF
16340 (NOT ACNIL)
16350 (SETQ RETNIL (USEDTAGP PAIREXIT))))
16360 (OUTJRST CONDEXIT))
16370 (T (RESTORE IRSSL)))))
16380 (SETQ ACS (CAR H2))
16390 (SETQ PDL (CADR H2))
16400 (SETQ PDLDEPTH (LENGTH PDL))
16410 (COND ((USEDTAGP PAIREXIT) (OUTTAG PAIREXIT)))
16420 (GO ELOOP)
16430 NONIL(SETQ RETNIL NIL)
16440 ELOOP(SETQ ARGS (CDR ARGS))
16450 (GO LOOP)))
16460
16470
16480 (DFUNC (P2GO XPR VALAC TEST)
16490 (PROG (TAG)
16500 (COND ((OR (NOT (NULL VALAC)) (NOT (NULL TEST)))
16510 (USERERR GO FOR VALUE OR TEST P2GO)))
16520 (SETQ TAG (CADR XPR))
16530 (SAVEACS)
16540 (CLRPVARS)
16550 (COND ((ATOM TAG) (OUTJRST (EQUIVTAG TAG)))
16560 (T (LOADCOMP TAG GOTABAC) (OUTJRST VGO)))
16570 (RETURN (MARKVAL (NOT (NULL VALAC)) VALUEAC))))
16580
16590
16600 (DFUNC (P2PROG XPR VALAC TEST)
16610 (PROG (PSFLG PVR)
16620 (SETQ PVR (COND ((NOT (NULL VALAC)) VALAC)
16630 ((NOT (NULL TEST)) (FREEAC))
16640 (T NIL)))
16650 (SETQ PSFLG (SPECBIND (CADDR XPR) NIL))
16660 (SETQ PRGSPFLG NIL)
16670 (CLEAR1)
16680 (PROG (GOLIST EXIT EXITN PRSSL PROGSW VGO)
16690 (GUARDLOCS)
16700 (INCR P2CNT)
16710 (SETQ PROGSW T)
16720 (SETQ EXIT (NEXTSYM TAG))
16730 (SETQ EXITN (NEXTSYM TAG))
16740 (SETQ VGO (NEXTSYM TAG))
16750 (SETQ GOLIST (CONS (CONS NIL EXIT)
16760 (CONS (CONS NIL EXITN)
16770 (CONS (CONS NIL VGO)
16780 (CADR XPR)))))
16790 (SETQ PROGVARS (NONSPECVARS (CADDR XPR)))
16800 (SETQ XPR (CDDDR XPR))
16810 LOOP (COND ((NULL XPR) (GO EXITN)))
16820 (INCR P2CNT)
16830 (COND ((NOT PROGSW) (RESTORE PRSSL)))
16840 (COND ((TAGP (CAR XPR)) (PROGTAG (CAR XPR)))
16850 ((AND (NULL (CDR XPR)) (EQ (CAAR XPR) (Q RETURN)))
16860 (COND ((EQUAL (CDAR XPR) (Q ((QUOTE NIL))))
16870 (GO EXITN))
16880 (T (LOADCOMP (CADAR XPR) PVR)
16890 (COND ((USEDTAGP EXITN) (OUTJRST EXIT)
16900 (GO EXITN))
16910 (T (GO EXIT))))))
16920 (T (COMPSTAT (CAR XPR))))
16930 (SETQ XPR (CDR XPR))
16940 (GO LOOP)
16950 EXITN(OUTENDTAG EXITN)
16960 (COND ((NOT (EQ (CAAR LASTOUT) (Q JRST)))
16970 (LOADARG PVR (Q (NIL . QT)))))
16980 EXIT (OUTENDTAG EXIT)
16990 (INCR P2CNT)
17000 (INCR P2CNT)
17010 (COND ((USEDTAGP VGO)
17020 (OUTGOTAB (CONS VGO (CDDDR GOLIST))))))
17030 (COND (PSFLG (OUTINST (Q (PUSHJ P SPECSTR)))))
17040 (RETURN (MARKVAL (NOT (NULL PVR)) PVR))))
17050
17060
17070 (DFUNC (P2PROG2 XPR VALAC TEST)
17080 (PROG (ARGS ARG2)
17090 (SETQ ARGS (CDR XPR))
17100 (COND ((LESSP (LENGTH ARGS) 2) (USERERR TOFEWARGS-P2PROG2)))
17110 (COMPSTAT (CAR ARGS))
17120 (COND ((NULL (CDDR ARGS))
17130 (RETURN (COMPFORM (CADR ARGS) VALAC TEST))))
17140 (COND ((OR (NOT (NULL VALAC)) (NOT (NULL TEST)))
17150 (SETQ ARG2 (COMPEXPR (CADR ARGS) VALAC)))
17160 (T (COMPSTAT (CADR ARGS))))
17170 (SETQ ARGS (CDDR ARGS))
17180 LOOP (COND ((NULL ARGS) (RETURN (TESTJUMP ARG2 TEST))))
17190 (COMPSTAT (CAR ARGS))
17200 (SETQ ARGS (CDR ARGS))
17210 (GO LOOP)))
17220
17230 (DFUNC (P2PROGN XPR VALAC TEST)
17240 (PROG (ARGS)
17250 (COND ((NULL (SETQ ARGS (CDR XPR))) (RETURN NIL)))
17260 LOOP (COND ((NULL (CDR ARGS))
17270 (RETURN (COMPFORM (CAR ARGS) VALAC TEST))))
17280 (COMPSTAT (CAR ARGS))
17290 (SETQ ARGS (CDR ARGS))
17300 (GO LOOP)))
17310
17320 (DFUNC (P2QUOTE XPR VALAC TEST)
17330 (PROG2 (COND ((NOT (NULL TEST))
17340 (BOOLARGS NIL
17350 (IFIF (CAR TEST) (CADR XPR))
17360 (CDR TEST)
17370 NIL)))
17380 (CONS (CADR XPR) (Q QT))))
17390
17400 (DFUNC (P2RETURN XPR VALAC TEST)
17410 (COND ((OR (NOT (NULL VALAC)) (NOT (NULL TEST)))
17420 (USERERR RETURN FOR VALUE OR TEST P2RETURN))
17430 (T (SAVEACS)
17440 (CLRPVARS)
17450 (COND ((EQUAL (CADR XPR) (Q (QUOTE NIL))) (OUTJRST EXITN))
17460 (T (LOADCOMP (CADR XPR) PVR) (OUTJRST EXIT))))))
17470
17480
17490 (DFUNC (P2RPLAC XPR VALAC TEST)
17500 (PROG (ARG1 ARG2)
17510 (SETQ ARG1 (COMPEXPR (CADR XPR) (FREEAC)))
17520 (SETQ ARG2 (COMPEXPR (CADDR XPR) (FREEAC)))
17530 (ILOC1 ARG1 VALAC)
17540 (LOC ARG2)
17550 (CLEARBOTH)
17560 (COND ((EQUAL ARG2 (Q (NIL . QT)))
17570 (OUT1 (CADR (ASSOC (CAR XPR)
17580 (Q ((RPLACA HRRZS@)
17590 (RPLACD HLLZS@)))))
17600 0
17610 (LOC ARG1)))
17620 (T (OUT1 (CADR (ASSOC (CAR XPR)
17630 (Q ((RPLACA HRLM@)
17640 (RPLACD HRRM@)))))
17650 (PUTINAC ARG2 (FREEAC))
17660 (LOC ARG1))))
17670 (REMOVE ARG2)
17680 (COND ((NULL VALAC) (REMOVE ARG1)))
17690 (RETURN ARG1)))
17700
17710 (DFUNC (P2SETARG XPR VALAC TEST)
17720 (PROG (TEM)
17730 (LOC (SETQ TEM (COMPEXPR (CADDR XPR) VALAC)))
17740 (COND ((EQ (CAADR XPR) (Q QUOTE))
17750 (OUT1 (Q MOVE) 2 (MINUS (ADD1 (PDLDEPTH))))
17760 (RETURN (OUTINST (LIST (Q HRRM)
17770 (PUTINAC TEM VALAC)
17780 (CADADR XPR)
17790 2)))))
17800 (LOADCOMP (COMPEXPR (CADR XPR)) 2)
17810 (CLEARACS)
17820 (OUT1 (Q ADD) 2 (MINUS (ADD1 (PDLDEPTH))))
17830 (OUTINST (LIST (Q HRRM)
17840 (PUTINAC TEM VALAC)
17850 (MINUS INUM0)
17860 2))))
17870
17880
17890 (DFUNC (P2SETQ XPR VALAC TEST)
17900 (PROG (NVAR VALLOC HOME VAR VAL TEM AC)
17910 (SETQ AC (COND ((NULL VALAC) (FREEAC)) (T VALAC)))
17920 (SETQ VAR (CADR XPR))
17930 (SETQ VAL (COMPEXPR (CADDR XPR) AC))
17940 (ILOC1 VAL AC)
17950 (COND ((AND (SPECVARP VAR) (SETQ TEM (ASSOC VAR LDLST)))
17960 (CLRSPVAR TEM)))
17970 (REMOVE VAL)
17980 (FREEZE VAR)
17990 (SETQ VALLOC (LOC VAL))
18000 (SETQ HOME (COND ((SPECVARP VAR) T)
18010 ((NOT (ILOC (SETQ NVAR (CONS VAR P2CNT)) AC))
18020 NIL)
18030 (T (NOT (DVP (SLOTCONT (LOC NVAR)))))))
18040 (INCR P2CNT)
18050 (COND ((AND (NULL VALAC) (NOT HOME))
18060 (COND ((AND (NUMBERP VALLOC)
18070 (NOT (DVP (SLOTCONT VALLOC))))
18080 (SETSLOT VALLOC (LIST VAR))
18090 (GO EXIT))
18100 (T (SLOTPUSH (LIST VAR))
18110 (OUTPUSH VALLOC)
18120 (GO EXIT)))))
18130 (COND ((AND HOME (EQUAL VAL (Q (NIL . QT))))
18140 (SETQ VAL (COND ((SPECVARP VAR) (LIST (Q SPECIAL) VAR))
18150 (T (ILOC (CONS VAR (SUB1 P2CNT)) AC))))
18160 (COND ((NUMBERP VAL) (SETSLOT VAL (LIST VAR))))
18170 (COND ((OR (NULL VALAC) (DVP (SLOTCONT AC)))
18180 (OUT1 (Q CLEARM) 0 VAL))
18190 (T (SETSLOT AC (CONS VAR (Q DUP)))
18200 (OUT1 (Q CLEARB) AC VAL)))
18210 (GO EXIT)))
18220 (COND ((OR (NOT (NUMBERP VALLOC))
18230 (LESSP VALLOC 0)
18240 (DVP (SLOTCONT VALLOC)))
18250 (LOADARG AC VAL)
18260 (SETQ VALLOC AC)))
18270 (SETSLOT VALLOC (LIST VAR))
18280 (COND ((SPECVARP VAR)
18290 (COND ((ZEROP VALLOC) (OUTPOP (LIST (Q SPECIAL) VAR)))
18300 (T (OUTMOVEM VALLOC (LIST (Q SPECIAL) VAR))))))
18310 EXIT (RETURN (COMPFORM VAR VALAC TEST))))
18320
18330
18340 (DFUNC (P2STORE XPR VALAC TEST)
18350 (PROG (TEM)
18360 (LOC (SETQ TEM (COMPEXPR (CADDR XPR)
18370 (COND ((NULL VALAC) (FREEAC))
18380 (T VALAC)))))
18390 (COMPSTAT (CADR XPR))
18400 (LOADARG ARRAYAC TEM)
18410 (OUTINST (Q (PUSHJ P NSTR)))
18420 (RETURN TEM)))
18430
18440 (DFUNC (PASS2 NAME EXPR FLAG)
18450 (PROG (ACS PDL PDLDEPTH MINDEPTH LDLST SPECFLAG PRGSPFLG CCLST
18460 VARLIST PROGVARS PROGSW GOLIST CTAG RSL)
18470 (SETQ P2CNT 1)
18480 (SETQ ACS (LISTNILS NACS))
18490 (SETQ ALLACS (SUB1 (LSH 1 NACS)))
18500 (SETQ PDL NIL)
18510 (SETQ PDLDEPTH (LENGTH PDL))
18520 (SETQ MINDEPTH (PDLDEPTH))
18530 (BINDARGS (CADR EXPR))
18540 (COND ((NOT (ATMARGIN)) (LINEF 2)))
18550 (OUTPSOP (LIST (Q LAP) NAME FLAG))
18560 (COND ((EQ (CAR EXPR) (Q FSUBR))
18570 (COND ((NOT (NULL (CDADR EXPR)))
18580 (OUTINST (Q (PUSHJ P *AMAKE))))))
18590 ((EQ (CAR EXPR) (Q LSUBR))
18600 (OUTINST (Q (JSP 3 *LCALL)))
18610 (INITPROP (Q ARG) (Q P2) (Q P2ARG))))
18620 (SETQ SPECFLAG (SPECBIND (CADR EXPR) T))
18630 (COND ((NOT (EQ (CAADDR EXPR) (Q PROG))) (SETQ PRGSPFLG NIL)))
18640 (LOADCOMP (CADDR EXPR) VALUEAC)
18650 (EXITBUM SPECFLAG)
18660 (OUTINST (OUTINST NIL))
18670 (COND ((EQ (CAR EXPR) (Q LSUBR)) (DELETEPROP (Q ARG) (Q P2))))
18680 (COND (LDLST (COMPERR LDLSTLEFT-PASS2)))
18690 (RETURN NIL)))
18700
18710 (DFUNC (PROGTAG TAG)
18720 (PROGN (CLEARBOTH)
18730 (CLEARACS)
18740 (CLRPVARS)
18750 (RESTORE PRSSL)
18760 (OUTTAG (EQUIVTAG TAG))))
18770
18780
18790 (DFUNC (PROTECTACS X)
18800 (PROG (WHICHACS ACNO)
18810 (SETQ WHICHACS (ACEFFECTS X))
18820 (SETQ ACNO 0)
18830 LOOP (SETQ ACNO (ADD1 ACNO))
18840 (COND ((ZEROP WHICHACS) (RETURN NIL))
18850 ((NOT (ZEROP (BOOLE 1 1 WHICHACS))) (CLEARAC ACNO)))
18860 (SETQ WHICHACS (LSH WHICHACS -1))
18870 (GO LOOP)))
18880
18890 (DFUNC (PUTINAC X AC)
18900 (PROG (Z)
18910 (SETQ Z (LOC X))
18920 (COND ((NOT (ACNUMP Z)) (LOADARG (SETQ Z AC) X)))
18930 (REMOVE X)
18940 (CPUSH Z)
18950 (RETURN Z)))
18960
18970 (DFUNC (REMOVE DATA)
18980 (PROG (TEM)
18990 (SETQ TEM (GETPROP (Q LDLST) (Q VALUE)))
19000 LOOP (COND ((NULL (CDR TEM)) (RETURN NIL)))
19010 (COND ((EQUAL (CADR TEM) DATA) (RPLACD TEM (CDDR TEM)))
19020 (T (SETQ TEM (CDR TEM))))
19030 (GO LOOP)))
19040
19050
19060 (DFUNC (RESTORE OLDPDL)
19070 (PROG (C V R TEM OLDDEPTH DEPTHDIF)
19080 (SETQ OLDDEPTH (LENGTH OLDPDL))
19090 (COND ((GREATERP OLDDEPTH (PDLDEPTH))
19100 (PRINTMSG (LIST OLDPDL PDL))
19110 (COMPERR PDLSHORT-RESTORE)))
19120 A1 (SETQ C 0)
19130 A (COND ((EQUAL OLDDEPTH (PDLDEPTH)) (RETURN (SHRINKPDL C)))
19140 ((DVP (SETQ R (CAR PDL))) (GO CPP)))
19150 (SETQ C (ADD1 C))
19160 (SLOTPOP)
19170 (GO A)
19180 CPP (SHRINKPDL C)
19190 CPP1 (SETQ V OLDPDL)
19200 (SETQ C 0)
19210 (SETQ DEPTHDIF (*DIF (PDLDEPTH) OLDDEPTH))
19220 CPP3 (COND ((NULL V) (SETQ V (FINDFREEAC))
19230 (COND ((NULL V) (COMPERR NOAC-RESTORE)))
19240 (SETSLOT V R)
19250 (OUTPOP V)
19260 (GO A1))
19270 ((AND (CAR V)
19280 (EQ (CAAR V) (CAR R))
19290 (NOT (DVP (SLOTCONT (SETQ TEM
19300 (MINUS (PLUS C
19310 DEPTHDIF)))))))
19320 (GO CPP2)))
19330 (SETQ C (ADD1 C))
19340 (SETQ V (CDR V))
19350 (GO CPP3)
19360 CPP2 (SETSLOT TEM R)
19370 (OUTPOP TEM)
19380 (GO A1)))
19390
19400 (DFUNC (RSLSET X)
19410 (COND ((EQ X CTAG)
19420 (SETQ RSL (COND ((AND RSL
19430 (NOT (AND (EQUAL (CAR RSL) ACS)
19440 (EQUAL (CADR RSL) PDL))))
19450 (Q LOSE))
19460 (T (LIST (TOPCOPY ACS) (TOPCOPY PDL))))))))
19470
19480 (DFUNC (RST TAG)
19490 (COND ((NULL TAG) NIL)
19500 ((ASSOCR TAG GOLIST) (RESTORE PRSSL))
19510 ((REMPROP TAG (Q SET)) (SAVEACS)
19520 (PUTPROP TAG (TOPCOPY PDL) (Q LEVEL))
19530 (SETQ MINDEPTH (PDLDEPTH)))
19540 ((SETQ TAG (SEEKPROP TAG (Q LEVEL))) (RESTORE (PROPVAL TAG)))
19550 (T (COMPERR NIL-RST))))
19560
19570
19580 (DFUNC (SAVEACS)
19590 (PROG (K)
19600 (SETQ K 0)
19610 LOOP (COND ((EQ K NACS) (RETURN NIL)))
19620 (CPUSH (SETQ K (ADD1 K)))
19630 (GO LOOP)))
19640
19650 (DFUNC (SETSLOT X Y) (RPLACA (GETSLOT X) Y))
19660
19670 (DFUNC (SHRINKPDL C)
19680 (COND ((NOT (ZEROP C))
19690 (OUTINST (LIST (Q SUB) (Q P) (GENCONST 0 0 C C 0))))))
19700
19710 (DFUNC (SIDEEFFECTS FUN) (NOT (HASPROP FUN (Q ACS))))
19720
19730 (DFUNC (SLOTCONT X) (CAR (GETSLOT X)))
19740
19750 (DFUNC (SLOTPOP)
19760 (PROGN (SETQ PDLDEPTH (SUB1 PDLDEPTH)) (SETQ PDL (CDR PDL))))
19770
19780 (DFUNC (SLOTPUSH SC)
19790 (PROGN (SETQ PDLDEPTH (ADD1 PDLDEPTH)) (SETQ PDL (CONS SC PDL))))
19800
19810 (DFUNC (SPECBIND VARS LAMBDAP)
19820 (PROG (ACNUM SPFLG)
19830 (SETQ ACNUM 1)
19840 LOOP (COND ((NULL VARS) (RETURN SPFLG)))
19850 (COND ((NOT (SPECVARP (CAR VARS))) (GO ELOOP)))
19860 (COND ((NOT PRGSPFLG) (SETQ PRGSPFLG (SETQ SPFLG T))
19870 (OUTINST (Q (JSP 6 SPECBIND)))))
19880 (OUTINST (LIST 0
19890 (COND (LAMBDAP ACNUM) (T 0))
19900 (LIST (Q SPECIAL) (CAR VARS))))
19910 ELOOP(SETQ ACNUM (ADD1 ACNUM))
19920 (SETQ VARS (CDR VARS))
19930 (GO LOOP)))
19940
19950 (DFUNC (SPECVARP VAR) (MEMBER VAR SPECVARS))
19960
19970
19980 (DFUNC (TESTJUMP ITEM TEST)
19990 (PROG (AC FLAG TAG)
20000 (COND ((NULL TEST) (RETURN ITEM)))
20010 (SETQ FLAG (CAR TEST))
20020 (SETQ TAG (CDR TEST))
20030 (SETQ AC (PUTINAC ITEM (FREEAC)))
20040 (OUTCJMP FLAG AC TAG)
20050 (COND (FLAG (RSLSET TAG) (SETSLOT AC (Q (NIL . QT))))
20060 (T (SETQ FLAG (SLOTCONT AC))
20070 (SETSLOT AC (Q (NIL . QT)))
20080 (RSLSET TAG)
20090 (SETSLOT AC FLAG)))
20100 (RETURN ITEM)))
20110
20120 (DFUNC (TRANSOUT OP AC AD)
20130 (PROG (TEM IND)
20140 (COND ((OR (ATOM AD) (ATOM (CAR AD))) (GO DONE)))
20150 (SETQ AD (CAR AD))
20160 (COND ((SETQ TEM (SEEKPROP OP (Q IMMED)))
20170 (SETQ OP (PROPVAL TEM))
20180 (GO DONE)))
20190 (SETQ AD (GENCONST 0 0 AD 0 0))
20200 DONE (SETQ IND (COND ((OR (NOT (NUMBERP AD)) (GREATERP AD 0)) NIL)
20210 (T (LIST (Q P)))))
20220 (RETURN (MCONS OP AC AD IND))))
20230
20240 (DFUNC (USEDTAGP TAG) (HASPROP TAG (Q USED)))
20250
20260 (MAPDEF PASS2 (EXPR CALLSUBR) (SUBR CALLSUBR) (*SUBR CALLSUBR)
20270 (*UNDEF CALLSUBR) (LSUBR CALLLSUBR) (*LSUBR CALLLSUBR)
20280 (FEXPR CALLFSUBR) (FSUBR CALLFSUBR) (*FSUBR CALLFSUBR)
20290 (FUNVAR CALLFUNARGS) (CARCDR P2CARCDR)
20300 (P2BOOL DOP2BOOL) (P2ELSE DOP2ELSE) (P2VAL DOP2VAL))
20310
20320 (MAPDEF P2BOOL (AND BOOLAND) (NULL BOOLNULL) (OR BOOLOR))
20330
20340 (MAPDEF P2ELSE (EQ BOOLEQ) (GO P2GO) (QUOTE P2QUOTE) (PROG2 P2PROG2)
20350 (RETURN P2RETURN) (SETQ P2SETQ))
20360
20370 (MAPDEF P2VAL (ARG P2ARG) (*EVAL P2*EVAL) (COND P2COND) (PROG P2PROG)
20380 (PROGN P2PROGN) (RETURN P2RETURN) (RPLACA P2RPLAC)
20390 (RPLACD P2RPLAC) (SETARG P2SETARG) (STORE P2STORE))
20400
20410 (SETQ CARCDRDEPTH 4)
20420
20430
20440 (PROG (BASE COUNT LIMIT MIDDLE NAME)
20450 (SETQ BASE 2)
20460 (SETQ LIMIT (SUB1 (LSH 1 (ADD1 CARCDRDEPTH))))
20470 (SETQ COUNT (LSH 1 1))
20480 LOOP (COND ((GREATERP COUNT LIMIT) (RETURN NIL)))
20490 (SETQ MIDDLE (SUBST (QUOTE A)
20500 0
20510 (SUBST (QUOTE D) 1 (CDR (EXPLODE COUNT)))))
20520 (SETQ NAME (READLIST (APPEND (QUOTE (C)) MIDDLE (QUOTE (R)))))
20530 (PUTPROP NAME
20540 (CONS (CAR MIDDLE)
20550 (COND ((CDR MIDDLE)
20560 (READLIST (APPEND (QUOTE (C))
20570 (CDR MIDDLE)
20580 (QUOTE (R)))))))
20590 (QUOTE CARCDR))
20600 (SETQ COUNT (ADD1 COUNT))
20610 (GO LOOP))
20620
20630 (MAPDEF ACS (*APPEND 37) (ATOM 1) (CONS 3) (GENSYM 7) (GET 1)
20640 (LAST 3) (LENGTH 7) (MEMBER 37) (NCONS 3) (XCONS 3))
20650
20660 (MAPDEF COMMU (CONS XCONS) (EQUAL EQUAL) (*GREAT *LESS)
20670 (*LESS *GREAT) (*PLUS *PLUS) (*TIMES *TIMES))
20680
20690 (MAPDEF IMMED (CAME CAIE) (CAMN CAIN) (HLLZS@ HLLZS) (HLRZ@ HLRZ)
20700 (HRLM@ HRLM) (HRRM@ HRRM) (HRRZ@ HRRZ) (HRRZS@ HRRZS)
20710 (MOVE MOVEI))
20720
20730 (SETQ NACS 5)
20740
20750 (SETQ VALUEAC 1)
20760
20770 (SETQ FARGAC 1)
20780
20790 (SETQ GOTABAC 1)
20800
20810 (SETQ ARRAYAC 1)
20820
20830 (SETQ INUM0 (MAKNUM 0 (QUOTE FIXNUM)))
20840
20850 (ENDBLOCK PASS2)
20860
20870 (BEGINBLOCK DEBUG)
20880
20890
20900 (DFUNC (CMPBREAK TYPE MESSAGE)
20910 (PROG NIL
20920 (INC NIL T)
20930 (OUTC NIL T)
20940 (COND ((ATMARGIN) (LINEF 1)) (T (LINEF 2)))
20950 (PRINL (APPEND TYPE MESSAGE))
20960 (LINEF 1)
20970 LOOP (COND ((EQUAL (ERRSET (EVALREAD)) (Q (PROCEED)))
20980 (RETURN (Q DONE))))
20990 (GO LOOP)))
21000
21010 (DEFPROP COMPERR
21020 (LAMBDA (L) (CMPBREAK (Q (*COMPILER ERROR*)) L))
21030 FEXPR)
21040
21050 (DFUNC (EVALREAD)
21060 (PROG (EX)
21070 (LINEF 1)
21080 (SETQ EX (READ))
21090 (PRINC *SP)
21100 (RETURN (PRINC (EVAL EX)))))
21110
21120 (DFUNC (LAPNOTES) (COPY (MAPCAR (FUNCTION EVAL) TRACELIST)))
21130
21140 (DEFPROP USERERR (LAMBDA (L) (CMPBREAK (Q (*USER ERROR*)) L)) FEXPR)
21150
21160 (SETQ TRACELIST NIL)
21170
21180 (ENDBLOCK DEBUG)
21190
21200 (BEGINBLOCK IO)
21210
21220 (DFUNC (ATMARGIN) (EQ (CHRCT) (LINELENGTH NIL)))
21230
21240 (DFUNC (CARRETN) (COND ((NOT (ATMARGIN)) (LINEF 1))))
21250
21260 (DFUNC (CURCOL) (*DIF (ADD1 (LINELENGTH NIL)) (CHRCT)))
21270
21280 (DFUNC (FORMF) (PROGN (PRINC *FF) (SETQ LINCNT PAGEHEIGHT)))
21290
21300 (DFUNC (LINEF N)
21310 (PROG NIL
21320 LOOP (COND ((ZEROP N) (RETURN NIL)))
21330 (TERPRI)
21340 (SETQ N (SUB1 N))
21350 (GO LOOP)))
21360
21370 (DFUNC (PRINL L) (MAPC (FUNCTION PRINS) L))
21380
21390
21400 (DFUNC (PRINS FN)
21410 (PROG2 (COND ((GREATERP (ADD1 (FLATSIZE FN)) (CHRCT)) (LINEF 1)))
21420 (PRINTEXPR FN)))
21430
21440 (DFUNC (PRINTEXPR XPR) (PROG2 (PRIN1 XPR) (PRINC *SP)))
21450
21460 (DFUNC (PRINTN CHAR NUM)
21470 (PROG (NO)
21480 (SETQ NO 1)
21490 LOOP (COND ((LESSP NUM NO) (RETURN NUM)))
21500 (PRINC CHAR)
21510 (SETQ NO (ADD1 NO))
21520 (GO LOOP)))
21530
21540 (DFUNC (PRINTSTAT STAT)
21550 (PROG2 (COND ((NULL STAT) (CARRETN) (TABTO 10))
21560 ((ATOM STAT) (TABTO 2))
21570 ((EQ (CAR STAT) (Q LAP)) (TABTO 1))
21580 (T (TABTO 10)))
21590 (PRINTEXPR STAT)))
21600
21610 (DFUNC (TABTO COL)
21620 (PROGN (COND ((GREATERP (CURCOL) COL) (LINEF 1)))
21630 (PRINTN *TB
21640 (*DIF (LSH (SUB1 COL) -3) (LSH (SUB1 (CURCOL)) -3)))
21650 (PRINTN *SP (*DIF COL (CURCOL)))))
21660
21670
21680 (MAPCAR (FUNCTION (LAMBDA (PAIR)
21690 (PROG2 (SET (CAR PAIR)
21700 (INTERN (ASCII (CADR PAIR))))
21710 (CAR PAIR))))
21720 (QUOTE ((*SP 40) (*TB 11)
21730 (*CR 15)
21740 (*LF 12)
21750 (*VT 13)
21760 (*FF 14)
21770 (*CO 54)
21780 (*PT 56)
21790 (*LP 50)
21800 (*RP 51)
21810 (*SL 57)
21820 (*AM 33)
21830 (*AT 100)
21840 (*RO 177)
21850 (*COLON 72))))
21860
21870 (SETQ LINCNT 0)
21880
21890 (SETQ PAGEHEIGHT 74)
21900
21910 (SETQ PAGEWIDTH 120)
21920
21930 (ENDBLOCK IO)
21940
21950 (BEGINBLOCK GENERAL)
21960
21970 (DFUNC (ADDTOLIST X Y) (COND ((MEMBER X Y) Y) (T (CONS X Y))))
21980
21990 (DFUNC (ASSOCR X Y)
22000 (PROG NIL
22010 LOOP (COND ((NULL Y) (RETURN NIL))
22020 ((EQ X (CDAR Y)) (RETURN (CAR Y))))
22030 (SETQ Y (CDR Y))
22040 (GO LOOP)))
22050
22060 (DFUNC (CONSTANTP XPR) (OR (NUMBERP XPR) (MEMBER XPR (Q (T NIL)))))
22070
22080 (DFUNC (COPY EX) (SUBST 0 0 EX))
22090
22100 (DFUNC (DEINITSYM NAME) (DELETEPROP NAME (Q SYMNO)))
22110
22120 (DFUNC (FSUBRP FUN) (GETL FUN (Q (FEXPR *FSUBR FSUBR))))
22130
22140
22150 (DFUNC (GETGET ATOM PROP)
22160 (PROG (TEM PTAB)
22170 (SETQ PTAB (FIRSTPROP ATOM))
22180 LOOP (COND ((LASTPROP PTAB) (RETURN NIL)))
22190 (COND ((SETQ TEM (SEEKPROP (PROPNAM PTAB) PROP))
22200 (RETURN TEM)))
22210 (SETQ PTAB (NEXTPROP PTAB))
22220 (GO LOOP)))
22230
22240 (DFUNC (LSUBRP FUN) (GETL FUN (Q (LSUBR *LSUBR))))
22250
22260 (DFUNC (MAKESPECIAL VAR)
22270 (PROGN (COND ((HASPROP VAR (Q LOCAL))
22280 (PRINTMSG (CONS VAR (Q (LOCAL AND SPECIAL))))))
22290 (SETPROP VAR (Q SPECIAL) T)
22300 VAR))
22310
22320 (DFUNC (MAKESYM IDENT NUMBER)
22330 (PROG (*NOPOINT)
22340 (SETQ *NOPOINT T)
22350 (RETURN (MAKNAM (APPEND (EXPLODE IDENT) (EXPLODE NUMBER))))))
22360
22370 (DFUNC (MAKEUNSPECIAL VAR) (COND ((REMPROP VAR (Q SPECIAL)) VAR)))
22380
22390 (DEFPROP NEXTSYM
22400 (LAMBDA (NAME)
22410 (PROG (NUM)
22420 (SETQ NUM (GETPROP (CAR NAME) (Q SYMNO)))
22430 (PUTPROP (CAR NAME) (ADD1 NUM) (Q SYMNO))
22440 (RETURN (MAKESYM (CAR NAME) NUM))))
22450 FEXPR)
22460
22470 (DFUNC (NTHCDR NUM EXP)
22480 (PROG NIL
22490 (COND ((MINUSP NUM) (COMPERR NEGNUM-NTHCDR)))
22500 LOOP (COND ((ZEROP NUM) (RETURN EXP)))
22510 (COND ((ATOM EXP) (COMPERR ATOM-NTHCDR)))
22520 (SETQ EXP (CDR EXP))
22530 (SETQ NUM (SUB1 NUM))
22540 (GO LOOP)))
22550
22560 (DEFPROP PROGN (LAMBDA L (ARG L)) EXPR)
22570
22580 (DEFPROP STARTSYM
22590 (LAMBDA (SYMS)
22600 (PROG NIL
22610 LOOP (COND ((NULL SYMS) (RETURN NIL)))
22620 (INITPROP (CAR SYMS) (Q SYMNO) 1)
22630 (SETQ SYMS (CDR SYMS))
22640 (GO LOOP)))
22650 FEXPR)
22660
22670
22680 (DEFPROP STOPSYM
22690 (LAMBDA (SYMS)
22700 (PROG NIL
22710 LOOP (COND ((NULL SYMS) (RETURN NIL)))
22720 (DELETEPROP (CAR SYMS) (Q SYMNO))
22730 (SETQ SYMS (CDR SYMS))
22740 (GO LOOP)))
22750 FEXPR)
22760
22770 (DFUNC (SUBRP FUN) (GETL FUN (Q (EXPR SUBR ARRAY *SUBR *UNDEF))))
22780
22790 (DFUNC (TOPCOPY SXP) (APPEND SXP NIL))
22800
22810 (ENDBLOCK GENERAL)
22820
22830 (ENDBLOCK COMPILER)
22840