github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-03-25 17:58:40 +00:00
Code Issues Releases Wiki Activity
Files
c49773a0a02fac5370b94ed3e47a9d6b97bbf13f
PDP-10.its/src/comlap/complr.936
Eric Swenson c72c810b2f Updated to build compiler from source. 
Resolves #383.
2017-01-19 12:30:55 +01:00

3062 lines
102 KiB
Common Lisp
Executable File
Raw Blame History

This file contains invisible Unicode characters
This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
;;; COMPLR -*-LISP-*-
;;; **************************************************************
;;; ***** MACLISP ***** LISP COMPILER (COMPLR) *******************
;;; **************************************************************
;;; ** (C) Copyright 1981 Massachusetts Institute of Technology **
;;; ****** This is a Read-Only file! (All writes reserved) *******
;;; **************************************************************
(SETQ COMPLRVERNO '#.(let* ((file (caddr (truename infile)))
(x (readlist (exploden file))))
(setq |verno| (cond ((fixp x) file) ('/936)))))
(EVAL-WHEN (COMPILE)
(AND (OR (NOT (GET 'COMPDECLARE 'MACRO))
(NOT (GET 'OUTFS 'MACRO)))
(LOAD `(,(cond ((status feature ITS) '(DSK COMLAP))
('(LISP)))
CDMACS
FASL)))
)
(EVAL-WHEN (COMPILE)
(ALLOC '(LIST (55296. 65536. 0.2) FIXNUM (4096. 6144. 0.2)))
(COMPDECLARE)
(FASLDECLARE)
(GENPREFIX |/|cl|))
(DEFUN COMPLRVERNO () ;PRINCs version number
(SETQ ^W (SETQ ^R (SETQ ^Q () )))
(PRINC '|/îLISP COMPILER |)
(AND (STATUS FEATURE GG)
(PRINC '|[Running Interpretively] |))
(PRINC (OR (GET 'COMPLR 'VERSION) COMPLRVERNO))
(COND ((STATUS FEATURE SHARABLE) (PRINC '| [in (SHARABLE) LISP |))
('T (PRINC '| [in LISP |)))
(PRINC (STATUS LISPV))
(PRINC '|]|)
() )
(COMMENT CHOMP CL and COMPILE)
(DEFUN CHOMP FEXPR (L)
#%(LET ((VL (COND ((NOT (ATOM (CAR L))) (PROG2 () (CAR L) (SETQ L (CDR L))))))
(MSGFILES '(T)) (CMSGFILES '(T)) (READTABLE CREADTABLE)
(FASLPUSH 'T) (YESWARNTTY 'T) (COMPILER-STATE 'COMPILE)
(*LOC 0) (FILOC 0) (LITLOC 0) (SYMBOLS SYMBOLS)
DATA TOPFN ^W ^Q ^R PURE *PURE LAPLL FASL ASSEMBLE NOLAP UNFASLSIGNIF
CURRENTFNSYMS CURRENTFN MAINSYMPDL SYMPDL ENTRYNAMES ALLATOMS
DDTSYMP ATOMINDEX SYMBOLSP LITERALS )
(LAP-A-LIST '(()) ) ;Be sure LAP is loaded
(SETQ L (MAPCAN '(LAMBDA (X)
(COND ((GETL X '(EXPR FEXPR))
(AND (SETQ DATA (GETL X '(SUBR FSUBR LSUBR)))
(NOT (SYSP X))
(REMPROP X (CAR DATA)))
(LIST X))))
L))
(COND ((NULL VL) (MAPC 'CHMP1 L))
((CHMP2 L)))
L))
(DEFUN CHMP1 (X) ;"CHOMP" one function
(SETQ DATA (GETL X '(EXPR FEXPR)) CFVFL () LAPLL () )
(COMPILE X (CAR DATA) (CADR DATA) () () )
(LAP-A-LIST (SETQ LAPLL (NREVERSE LAPLL)))
(AND (COND ((SYSP X)
(AND (SETQ DATA (GETL X '(EXPR FEXPR SUBR FSUBR LSUBR)))
(MEMQ (CAR DATA) '(EXPR FEXPR))
(SETQ DATA '(SUBR FSUBR LSUBR))))
('T (AND (SETQ DATA (GETL X '(*EXPR *FEXPR *LEXPR SUBR FSUBR LSUBR)))
(MEMQ (CAR DATA) '(SUBR FSUBR LSUBR))
(SETQ DATA '(*EXPR *FEXPR *LEXPR)))))
(SETQ DATA (CAR (GETL X DATA)))
(PUTPROP X (CAR (REMPROP X DATA)) DATA)))
(DEFUN CL FEXPR (L) ;Compile a list of functions given by atom name
#%(LET (LAPLL DATA (SYMBOLS SYMBOLS) (READTABLE CREADTABLE) TOPFN
(COMPILER-STATE 'COMPILE) (YESWARNTTY 'T) (CMSGFILES '(T))
GAG-ERRBREAKS FASL FASLPUSH ASSEMBLE NOLAP)
(CONS 'COMMENT
(MAPCAR '(LAMBDA (J)
(AND (SETQ DATA (GETL J '(EXPR FEXPR)))
(PROG2 (SETQ CFVFL () TOPFN J)
(COMPILE J (CAR DATA) (CADR DATA) () () ))))
(SETQ CL (OR L CL))))))
((LAMBDA (X)
(PUTPROP 'CL:CL (CADR X) (CAR X)))
(GETL 'CL '(FSUBR FEXPR)))
(DEFUN COMPILE (NAME-ARG FLAG EXP file? P1GFY)
(PROG (*NOPOINT ACSMODE AL ARGNO ARITHP ATPL ATPL1 BVARS CNT CONDP
CONDUNSF CTAG DPL EFFS ERRFL EXLDL FL FLPDL REAL-SUBRP FXPDL GL
GOBRKL GONE2 HLAC IGNOREVARS KTYPE L-END-CNT LDLST LMBP LOCVARS
LOUT LOUT1 LPRSL LSUBRF MARR-LOSS MODELIST NAME NARGS NLNVS
NLNVTHTBP NUMACS OLVRL OPVRL P1CNT P1CSQ P1LL P1LLCEK P1LSQ P1PSQ
P1SPECIALIZEDVS P2P PKTYP PNOB PROGP PROGUNSF PRSSL PVRL REGACS
REGPDL RNL ROSENCEK SFLG SPECVARS SPFL SPLDLST SYSFUNP TAKENAC1 TEM
UNSFLST VGOL VL)
(SETQ CNT 1 REAL-SUBRP 'T)
(COND ((ATOM NAME-ARG) (SETQ NAME NAME-ARG NAME-ARG () ))
('T (SETQ NAME (CAR NAME-ARG))
(SETQ REAL-SUBRP (MEMQ (CADDR NAME-ARG)
'(SUBR FSUBR LSUBR)))))
(COND ((NOT P1GFY)
(GENSYM 0)
(SETQ TOPFN NAME)
(COND ((SETQ SYSFUNP (SYSP NAME))
(COND
((COND ((AND (SETQ TEM (FUNTYP-DECODE NAME))
(NOT (GET NAME TEM)))
() )
(REAL-SUBRP 'T)
('T (AND (GET NAME 'ARGS)
(SETQ TEM (ARGS NAME))
(NOT (EQUAL (GET NAME 'ARGS) TEM))
(ARGS NAME ()))
() ))
(ARGS NAME ())
(SETQ SYSFUNP 'T)
(or (get name 'SKIP-WARNING)
(WARN (cond ((filep infile)
`(,name FROM USER FILE ,(namestring infile)))
(name))
|Redefining system function|))))))))
(COND ((NULL (EQ (CAR EXP) 'LAMBDA)) (DBARF EXP |No function| 4 6))
((AND (CADR EXP) (ATOM (CADR EXP)))
(COND (REAL-SUBRP
(AND (OR (GETL NAME '(*EXPR *FEXPR))
(NOT (MEMQ FLAG '(EXPR LEXPR))))
(WRNTYP NAME))
(ARGS NAME () )
(AND (MEMQ SYSFUNP '(T () ))
(PUTPROP NAME 'T '*LEXPR))))
(SETQ LSUBRF (SETQ FLAG 'LEXPR))
(SETQ EXP (CONS (CAR EXP) (CONS (LIST (CADR EXP)) (CDDR EXP))))))
(COND (LSUBRF)
((or (> (setq nargs (length (cadr exp))) #%(nacs))
(get name '**LEXPR))
(SETQ LSUBRF 'LSUBR FLAG 'LEXPR) ;CONVERT LONG EXPR TO LSUBR
(COND (REAL-SUBRP
(LREMPROP NAME '(*EXPR *FEXPR))
(COND ((AND (NOT P1GFY) (MEMQ SYSFUNP '(T () )))
(PUTPROP NAME 'T '*LEXPR)
(P1ACK NAME
'LSUBR
(SETQ AL (CONS NARGS NARGS))
NARGS) )))))
((COND ((NOT REAL-SUBRP) () )
((EQ FLAG 'EXPR)
(COND ((NOT P1GFY)
(SETQ AL (CONS () NARGS))
(P1ACK NAME 'SUBR AL NARGS)))
(SETQ FL '*EXPR)
'T)
((EQ FLAG 'FEXPR)
(REMPROP NAME 'ARGS)
(SETQ FL '*FEXPR)
'T))
(AND (SETQ SPFL (GETL NAME '(*EXPR *FEXPR *LEXPR)))
(NOT (EQ FL (CAR SPFL)))
(WRNTYP NAME))
(PUTPROP NAME 'T FL))
((EQ FLAG 'LEXPR) (SETQ LSUBRF 'LSUBR FLAG 'LEXPR)))
(SETQ KTYPE (AND REAL-SUBRP (GET NAME 'NUMFUN))
EXP (P1LMBIFY (CADR EXP) (CDDR KTYPE) (CDDR EXP))
P1LL (CAR EXP) EXP (CDR EXP))
(AND KTYPE (SETQ KTYPE (CADR KTYPE)))
(MAPC '(LAMBDA (X)
(COND ((AND X (NOT (SPECIALP X)) (NULL (VARMODE X)))
(PUSH X UNSFLST))))
P1LL)
(SETQ EXP (P1GLM P1LL EXP))
(SETQ UNSFLST (LSUB UNSFLST (P1SPECIALIZEDVS)))
(AND (SETQ FL (UUVP 'P1LL)) (WARN FL |Unused LAMBDA variables|))
(AND ERRFL (ERR 'DATA))
(AND NLNVS (NLNVASG (MAPCAR 'CAR NLNVS)))
(MAPC '(LAMBDA (X) (PUTPROP (CAR X) () 'OHOME)) LOCVARS)
(SETQ LOUT (LIST 'LAP
NAME
(COND ((NULL NAME-ARG)
(CDR (ASSQ FLAG COMPILATION-FLAGCONVERSION-TABLE)))
((NULL (CDDR NAME-ARG)) (CADR NAME-ARG))
((CADDR NAME-ARG)))))
(SETQ LOUT1 (SETQ ATPL1 'FOO)) ;ATPL is still ()
(AND (NOT (= BASE 8.))
((LAMBDA (B BASE)
(OUTPUT (SUBST B 'BASE '(EVAL (SETQ IBASE BASE))))
(PROG2 #%(|Oh, FOO!|) #%(|Oh, FOO!|))
(SETQ *NOPOINT () ))
BASE 8.))
(AND AL #%(OUTFS 'ARGS NAME AL))
(COND (SYMBOLS (OUTPUT '(SYMBOLS T))
(COND ((> (FLATC NAME) 5) (OUTPUT (GENSYM))))))
(AND KTYPE
(OUTPUT (COND ((EQ LSUBRF 'LEXPR)
(COND ((EQ KTYPE 'FIXNUM) '(JSP D (*LCALL -1)))
('(JSP D (*LCALL -2)))))
((EQ LSUBRF 'LSUBR)
(OUTPUT (COND ((EQ KTYPE 'FIXNUM) '(SKIPA T (% 0 0 FIX1A)))
('(SKIPA T (% 0 0 FLCONS)))))
(SETQ MARR-LOSS (LIST (GENSYM)))
'(MOVEI T 0))
((EQ KTYPE 'FIXNUM) '(PUSH P (% 0 0 FIX1)))
('(PUSH P (% 0 0 FLOAT1))))))
(SETQ HLAC (SETQ LPRSL (SETQ TAKENAC1 0)))
(SETQ P1CNT CNT CNT 1 BVARS () PNOB () P2P 'T)
(SETQ AL #%(INITIALSLOTS))
(SETQ REGACS (APPEND (CAR AL) () ))
(SETQ NUMACS (APPEND (CADR AL) () ))
(SETQ ACSMODE (APPEND NUMACS () ))
(SETQ REGPDL () FXPDL () FLPDL () )
(SETQ ARGNO (COND (KTYPE #%(NUMVALAC)) (1)))
(COND ((EQ LSUBRF 'LEXPR) (OUTPUT '(JSP D *LCALL)))
((EQ LSUBRF 'LSUBR)
(DO I NARGS (1- I) (ZEROP I) (PUSH () REGPDL))
(COND (MARR-LOSS
(SETQ FXPDL (LIST MARR-LOSS))
(PUSH MARR-LOSS LDLST)
(OUTPUT '(PUSH FXP T)))))
((AND (EQ FLAG 'FEXPR) (CDAR (CDDDDR EXP)))
(OUTPUT '(EXCH 1 2))
(OUTPUT '(MOVE TT SP))
(OUTPUT '(JSP T FIX1A))
(OUTPUT '(EXCH 1 2))))
(SETQ FL (CDDDDR EXP))
(CNPUSH (APPEND NLNVTHTBP (CAR (CDDDDR FL))) () )
(SETQ BVARS (APPEND (CAR FL) BVARS) ;LSUBRF = +1 => SUBR
LSUBRF (COND ((EQ LSUBRF 'LSUBR) -1) (+1))) ;LSUBRF = -1 => LSUBR
(SETQ SPFL SFLG)
(DO ((AC (LSH (1+ LSUBRF) -1) (+ AC LSUBRF))
(X (COND ((< LSUBRF 0) (REVERSE (CAR FL))) ((CAR FL))) (CDR X))
(MODE))
((NULL X))
(COND ((AND (CAR X) (SPECIALP (CAR X)))
(COND ((NULL SPFL)
(SETQ SPFL 'T)
(CPUSH #.(+ (NUMVALAC) 2))
(OUTPUT '(JSP T SPECBIND))))
(OSPB AC (CAR X))))
(COND ((NULL (CAR X)))
((> LSUBRF 0) (CONT AC (LIST (CAR X)))) ;SUBR TYPE
((NOT (SPECIALP (CAR X)))
(CONT AC (COND ((SETQ MODE (VARMODE (CAR X)))
(PUSH (CONS AC (CONS (LIST (CAR X)) MODE)) DPL)
())
('T (LIST (CAR X))))))))
(MAPC '(LAMBDA (L) (OPUSH (CAR L) (CADR L) (CDDR L))) DPL)
(SETQ EXP (CADDDR (CDDR EXP)))
(COND (DPL (SETQ SFLG () )) ;DPL is the delayed-pushes list
((SETQ SPFL (PROGHACSET SPFL EXP))))
(LOADAC (COMP EXP) ARGNO 'T) ;Since PNOB has been (), this should
; not cause a PDLNMK
(AND KTYPE
(SETQ FL (GETMODE0 ARGNO 'T () ))
(NOT (EQ KTYPE FL))
(WARN NAME |This function was declared numerical,
but the resultant type is incorrect|))
(COND (MARR-LOSS
(OUT1 'SKIPE 'T (ILOC1 () MARR-LOSS 'FIXNUM))
(OUTPUT '(JSP T 0 T))
#%(|Oh, FOO!|)
(REMOVE MARR-LOSS)))
(SETQ FL
(COND (SPFL '(JRST 0 UNBIND))
((AND (NOT (OR FXPDL FLPDL))
(NOT ATPL))
(COND ((AND (SETQ AL (ASSOC (CAR LOUT)
'((PUSHJ . JRST) (NCALL . NJCALL)
(CALL . JCALL) (NCALLF . NJCALF)
(CALLF . JCALLF))))
(COND ((OR (NULL (CDDDR LOUT))
(NOT (MEMQ '@ LOUT))
(NOT (NUMBERP (CADDDR LOUT)))))
((ZEROP (CADDDR LOUT))
(NOT (EQ (CADR (CDDDR LOUT)) 'P)))
((NOT #%(PDLLOCP (CADDDR LOUT))))))
(SETQ AL (CONS (CDR AL)
(COND ((EQ (CDR AL) 'JRST) (CONS 0 (CDDR LOUT)))
((CDR LOUT)))))
(SETQ LOUT (SETQ ATPL 'FOO))
AL)
((AND (EQ (CAR LOUT) 'JSP) (EQUAL LOUT '(JSP T PDLNMK)))
(SETQ LOUT (SETQ ATPL 'FOO))
'(JRST 0 PDLNKJ))
('T '(POPJ P))))
('T '(POPJ P))))
(CONT ARGNO '(NIL . TAKEN))
(RESTORE #%(INITIALSLOTS))
(OUTPUT FL)
(MAPC 'OUTG VGOL)
(COND (LDLST (BARF LDLST |Left on LDLST|)))
(AND SYMBOLS (NOT (EQ SYMBOLS 'T)) (OUTPUT '(SYMBOLS T)))
(OUTPUT () ) (OUTPUT () ) (OUTPUT () )
(COND ((NOT FASLPUSH) (ICOUTPUT GOFOO) (ICOUTPUT GOFOO)))
(GCTWA)
(COND ((NOT (= CNT P1CNT))
(BARF (LIST P1CNT CNT) |Unequal count|)))
(RETURN NAME)))
(COMMENT BASIC COMP FUNCTION and COMPFORM)
;;; Results from the "COMP" type functions can be
;;; () if computing for effects only; otherwise, is
;;; (QUOTE MUMBLE)
;;; (VAR . CNT)
;;; (G0005 . () )
;;; where G0005 is either 1) The internal name of some computational result, or
;;; 2) A carcdr'ing, like 1) above, but which may be delayed
(DEFUN COMP (X) ((LAMBDA (EFFS) (COMP0 X)) () )) ;For value
(DEFUN COMPE (X) ((LAMBDA (EFFS PNOB) (COMP0 X)) 'T 'T)) ;For effects
(DEFUN COMP1 (X) (COMPW X () 1)) ;For value, into accumulator 1
(DEFUN COMPW (X EFFS ARGNO) (COMP0 X)) ;Can specify effects and accumulator number
(DEFUN COMPR (X MODE OEFFS OPNOB) ;This seems to be useful in several places
(COND (MODE (COMPW X () (FREENUMAC)))
('T ((LAMBDA (EFFS PNOB ARGNO) (COMP0 X))
()
OPNOB
(COND (OEFFS 1)
((NOT #%(NUMACP-N ARGNO)) ARGNO)
(#%(FREAC)))))))
(DEFUN COMP0 (X) ;The basic "CHOMP"
((LAMBDA (Y MODE)
(COND ((EQ MODE 'SYMBOL) ;"CHOMPING" a variable
(SETQ CNT (ADD1 CNT))
(COND ((NULL EFFS)
(SETQ Y (CONS X CNT))
(COND ((SPECIALP X) (PUSH Y SPLDLST))
((ILOC0 Y (SETQ MODE (VARMODE X))))
((AND MODE (ILOC0 Y () )))
((COND ((OR (MEMQ X PVRL)
(DO Y OPVRL (CDR Y) (NULL Y)
(AND (MEMQ X (CAR Y))
(RETURN 'T))) )
(AND MODE (PDERR X |Uninitialized number variable|))
'T)
((MEMQ X OLVRL)))
(SETQ Y (COND ((NULL MODE) '(QUOTE () ))
((EQ MODE 'FIXNUM) '(QUOTE 0))
('T '(QUOTE 0.0)))))
((BARF Y |What kind of variable is this - COMP0|))))))
((NOT (EQ MODE 'LIST)) (BARF X |What is this cruft - COMP0|))
((EQ (CAR X) 'QUOTE) (SETQ Y X)) ;"CHOMPING" quoted frob
((AND (NOT (ATOM (CAR X))) (EQ (CAAR X) CARCDR)) ;"CHOMPING" a carcdring
(COND (EFFS (COMP0 (CADR X)))
('T (SETQ Y (COND ((NOT (SYMBOLP (CADR X)))
(COND (#%(NUMACP-N ARGNO) (COMP1 (CADR X)))
((COMP0 (CADR X)))))
((SPECIALP (CADR X))
(CAR (PUSH (CONS (CADR X) (SETQ CNT (ADD1 CNT)))
LDLST)))
('T (COMP0 (CADR X)))))
(PUSH (XCONS (CONS (CDAR X) Y)
(SETQ Y (GENSYM)))
SPLDLST)
(SETQ Y (LIST Y)))))
('T (SETQ Y (COMPFORM X))))
(COND ((NULL EFFS) (PUSH Y LDLST) Y)))
() (TYPEP X)))
(DEFUN COMPFORM (F)
(PROG (X Y Z FNARGS VALAC NARGS TEM T1 CCSLD ARRAYP JSP UNSAFEP)
(SETQ VALAC 1)
A (SETQ X (CAR F) Y (CDR F))
(AND (SETQ T1 (NOT (ATOM X))) ;Non-Atomic function forms
(COND ((EQ (CAR X) 'LAMBDA) (RETURN (COMLAMAP F)))
((EQ (CAR X) COMP)
(AND (SYMBOLP (CDDR X))
(SPECIALP (CDDR X))
#%(NO-DELAYED-SPLDS))
(SETQ FNARGS (COMP1 (CDDR X)))
(COND (CCSLD)
((AND (NULL Y)
(OR (NULL SPLDLST)
(PROG2 (CLEANUPSPL 'T)
(OR (NULL SPLDLST)
(AND (NULL (CDR SPLDLST))
(EQ (CAR FNARGS) (CAAR SPLDLST))))))))
('T #%(NO-DELAYED-SPLDS)))
(SETQ X (COND ((EQ (CADR X) 'FUNCALL)
(COND ((> (LENGTH Y) #%(NACS))
(SETQ
VALAC
(COMLC (LIST COMP 'FUNCALL FNARGS)
Y
() ))
(GO CALLX)))
() )
((CDR X))))
(LOADACS (SETQ Z (ITEML Y () )) (SETQ NARGS (LENGTH Z)) () )
(SETQ TEM #%(PDLLOCP (SETQ T1 (ILOCMODE FNARGS 'FRACF () ))))
(REMOVEB FNARGS)
(AND #%(CLEARALLACS) TEM (SETQ T1 (ILOC0 FNARGS () )))
(COND ((NULL X)
(OUT1 (COND ((AND (OR #%(NUMACP-N ARGNO) PNOB)
(VARBP (CAR FNARGS))
(SETQ F (OR (FUNMODE (CAR FNARGS))
(GET 'FNARGS 'NUMFUN)))
(SETQ F (CADR F)))
(RPLACA ACSMODE F) ;(SETMODE #%(NUMVALAC) FOO)
(SETQ VALAC #%(NUMVALAC))
'(NCALLF . NCALLF))
('(CALLF . CALLF)))
NARGS
T1))
('T (COND ((MEMQ (CAR X) '(FIXNUM FLONUM))
(OUT1 'MOVE #%(NUMVALAC) T1)
(OUTPUT #.(SUBST (NUMVALAC) 'AC ''(PUSHJ P 1 AC)))
(RPLACA ACSMODE (CAR X))
(SETQ VALAC #%(NUMVALAC)))
((OUT1 '(PUSHJ) 'P T1)))))
(AND TEM #%(|Oh, FOO!|))
(GO CALLX))
((NOT (EQ (CAR X) MAKUNBOUND)) (GO LOSTF))
((AND (EQ (CAR (SETQ X (CDR X))) 'FSUBR) (ATOM (CDR X)))
(AND (NOT (GET (CDR X) 'ACS)) #%(NO-DELAYED-SPLDS))
(LOADAC (COMPW Y () 1) 1 () )
(SETQ X (CDR X))
(GO F-*))
((EQ (CAR X) '*MAP)
(COND ((CADR X) #%(NO-DELAYED-SPLDS)) ;Mapping unknown funct
('T (CSLD () 'T () ))) ;Fun has no side-effects
(COND ((NOT (EQ (CADDR X) '*MAP))
(COMLC (CADDR X) Y () )
(GO CALLX)))
(LOADACS ((LAMBDA (EFFS ARGNO)
(LIST (COMP0 (CAR Y))
(COMP0 (PROG2 (SETQ ARGNO 1)
(CADR Y)))))
() 2)
2
() )
#%(CLEARALLACS)
#%(OUTFS 'PUSHJ 'P (CDDR X))
(GO CALLX))
((EQ (CAR X) 'RPLACD) (RETURN (COMRPLAC 'RPLACD Y 'T)))
((EQ (CAR X) 'MAKNUM)
(AND (NOT #%(NUMACP-N ARGNO)) (SETQ UNSAFEP PNOB))
(SETQ VALAC (COMMAKNUM Y))
(GO RETV))
((EQ X ARGLOC) ;bind to specific location
(SETQ VALAC (CAR Y)) ;mostly for use by CATCHALL
(GO RETV))
('T (GO LOSTF))))
(COND ((SETQ TEM (GETL X '(ARITHP NUMBERP NOTNUMP)))
(AND EFFS (OR (NOT (EQ (CAR TEM) 'NOTNUMP))
(EQ (CADR TEM) 'NOTNUMP))
(WARN F |You're losing some value here| 3 5))
(COND ((NOT (EQ (CAR TEM) 'NUMBERP))
(AND (EQ (CAR TEM) 'ARITHP)
(BARF F |ARITHP function in COMPFORM???|)))
((EQ (CADR TEM) 'NOTYPE)
(COND ((COND ((MEMQ X '(EQ EQUAL))
(COND ((OR (EQ X 'EQ)
(MEMQ (CAR Y) '(FIXNUM FLONUM)))
(COMEQ Y () 'T)
'T)))
((MEMQ X '(GREATERP LESSP *GREAT *LESS))
(COND (#%(KNOW-ALL-TYPES (CAR Y))
(COMGRTLSP F () 'T)
'T)))
((MEMQ X '(ZEROP PLUSP MINUSP ODDP))
(COND ((AND (NOT CLOSED)
(MEMQ (CAR Y) '(FIXNUM FLONUM)))
(COMZP F () 'T)
'T)))
((BARF F |Lost NOTYPE NUMBERP-function|)))
(BOOLOUT () () )
(GO RET-NO))
('T (SETQ F (CONS X (SETQ Y (CDR Y))))))
() )
((EQ X IDENTITY)
(SETQ Z (COMP0 (CADR Y)))
(COND ((NOT EFFS)
(SETQ T1 #%(ILOCNUM Z 'FREENUMAC))
(AND #%(NUMACP T1)
(NULL (GETMODE0 T1 'T () ))
(SETMODE T1 (CAR Y))) ))
(RETURN Z))
((OR (EQ X 'FIX)
(NULL (CAR Y))
(AND CLOSED (NOT (ATOM (CAR Y))))) ;For closed-CALL arith
(SETQ F (CONS X (SETQ Y (CDR Y))))
() )
((MEMQ X '(ADD1 SUB1)) (RETURN (COMAD1SB1 X Y)))
((MEMQ X '(PLUS DIFFERENCE TIMES QUOTIENT))
(RETURN (COMARITH X Y)))
((MEMQ X '(*DIF *PLUS *TIMES *QUO HAULONG))
(AND #%(KNOW-ALL-TYPES (CAR Y))
(RETURN (COND ((EQ X 'HAULONG) (COMHAULONG Y))
('T (COMARITH X Y)))))
(SETQ F (CONS X (SETQ Y (CDR Y))))
() )
((MEMQ X '(FLOAT IFIX))
(RETURN (COMFIXFLT (COMPW (CADR Y) () #%(NUMVALAC))
(COND ((EQ X 'FLOAT) 'FLONUM)
('FIXNUM)))))
((EQ X 'REMAINDER) (RETURN (COMREMAINDER (CDR Y))))
((MEMQ X '(ABS MINUS)) (RETURN (COMABSMINUS X Y))) )))
(COND ((SETQ T1 (FUNTYP-DECODE X))
(COND ((EQ T1 'FSUBR) ;Compile for Special Forms
(COND ((EQ X 'COND)
(SETQ UNSAFEP (AND PNOB (CADDR Y)))
(COMCOND Y () () () )
(AND (NOT EFFS)
#%(NUMACP-N ARGNO)
(NULL (CAR (SETQ TEM #%(ACSMODESLOT ARGNO))))
(RPLACA TEM (COND ((NULL (SETQ Z (CADDDR Y)))
(BARF () |No type for COMCOND|))
((ATOM Z) Z)
((CADR Z)))))
(GO RET-NO))
((EQ X 'PROG)
(SETQ VALAC (COMPROG Y))
(SETQ UNSAFEP (CADDR (CDDDDR Y)))
(GO RETV))
((EQ X 'SETQ) (RETURN (COMSETQ Y)))
((EQ X 'GO) (COMGO Y) (RETURN ''()))
((AND (EQ X 'ERR) (NULL (CDR Y)))
(LOADAC (COMP1 (CAR Y)) 1 'T)
(OUTPUT '(JRST 0 ERUNDO))
(GO RET))
((OR (EQ X 'COMMENT) (EQ X 'DECLARE))
(OUTPUT (CONS 'COMMENT Y))
(RETURN '(QUOTE COMMENT)))
((MEMQ X '(AND OR))
(COND ((NOT EFFS) (BARF F |AND or OR loss| 3 6)))
(CLEAR (CADR Y) 'T)
(SETQ Z (L2F (CDDDDR Y)))
(COND ((AND (NULL (CDDR Z))
(NOT (ATOM (CAR Z)))
(SETQ T1 (COND ((EQ (CAAR Z) 'GO)
(AND (ATOM (CADAR Z))
(ADR (CADAR Z))))
((EQ (CAAR Z) 'RETURN)
(AND (QNILP (CADAR Z))
(GENTAG 'EXITN)))))
(EASYGO))
(BOOL1 (CADR Z) T1 (EQ X 'AND))
(SETQ CNT (PLUS 2 CNT)))
('T (BOOL2LOOP (CDR Z)
(SETQ T1 (LEVELTAG))
(EQ X 'OR))
(COMPE (CAR Z))
(SETQ CNT (PLUS 2 CNT))
(OUTTAG T1)))
(DIDUP (CADDR Y))
(GO RET))
((EQ X 'SIGNP) (COMSIGNP Y () () ) (GO RETV))
((MEMQ X '(ERRSET *CATCH CATCH-BARRIER
%CATCHALL %PASS-THRU))
(SETQ Z (COMERSET X Y))
(COND ((EQ X 'ERRSET) (RETURN Z))
('T (GO RETV))))
((EQ X 'STORE)
(COND ((AND ARRAYOPEN
(ATOM (CAAR Y))
(COND ((AND (SETQ ARRAYP (GET (CAAR Y) '*ARRAY))
(NOT (EQ ARRAYP 'T)))
(SETQ X (CAAR Y) Z (CDAR Y))
(AND (SETQ T1 (GET X 'NUMFUN)) (SETQ T1 (CADR T1)))
(SETQ TEM (COMPR (CADR Y) T1 () () ))
'T)
((EQ (CAAR Y) 'ARRAYCALL)
(SETQ T1 (CADAR Y)
TEM (COMPR (CADR Y) T1 () () )
X (COMP1 (CADDAR Y))
Z (CDDDAR Y)
ARRAYP () )
'T)))
(SETQ Z (NREVERSE (ITEML Z '(FIXNUM FIXNUM FIXNUM
FIXNUM FIXNUM FIXNUM FIXNUM))))
(SETQ VALAC (COM-AREF X Z TEM T1 ARRAYP)))
(((LAMBDA (V LOC TAKENAC1)
(CONT TAKENAC1 () )
(REMOVE LOC)
(LOADAC V 1 'T)
(CLEARNUMACS)
(OUTPUT '(JSP T *STORE)))
(COMP1 (CADR Y))
(COMPW (CAR Y) 'T 1)
(+ #%(NUMVALAC) 2))))
(GO RETV))
((EQ X 'ARRAYCALL)
(SETQ VALAC (COMARRAY (COMP1 (CADR Y)) (CDDR Y) () (CAR Y)))
(GO RETV))
((EQ X 'LSUBRCALL)
(SETQ VALAC (COMLC (LIST COMP (CAR Y) (COMP1 (CADR Y)))
(CDDR Y)
() ))
(GO CALLX))
((EQ X 'PROGV)
(SETQ TEM (COMPW (CAR Y) () 5) T1 (COMP1 (CADR Y)))
(AND (NULL (ILOCMODE TEM 5 () ))
(DBARF F |Bad variables list|))
(LOADAC TEM 5 () ) ;Maybe should be safe things?
(LOADAC T1 1 () )
#%(CLEARALLACS)
(OUTPUT '(JSP T VBIND))
((LAMBDA (GOBRKL)
(SETQ TEM (COMPROGN (CDDR Y) EFFS))
(COND ((AND (NULL EFFS) (CDR TEM) (SPECIALP (CAR TEM)))
(LOADAC TEM ARGNO () )
(SETQ TEM () ))
('T (AND (NULL EFFS) #%(ILOCN TEM))
(REMOVEB TEM))))
(CONS '( UNBIND . () ) GOBRKL))
(OUTPUT '(PUSHJ P UNBIND))
(COND (TEM (RETURN TEM)) ((GO RETV))))
('T (GO F-FORM))))
((EQ T1 'SUBR) ;Compile for SUBR type
(COND ((EQ X 'NULL) (COMNULL (CAR Y)) (GO RET-NO))
((EQ X 'RETURN)
(COMRETURN Y 'T)
(CONT PVR () )
(RETURN ''()))
((MEMQ X '(RPLACA RPLACD SETPLIST))
(RETURN (COMRPLAC X Y () )))
((AND (EQ X '*PRINC)
(NOT (ATOM (CAR Y)))
(EQ (CAAR Y) 'QUOTE)
(STRTIBLE (CADAR Y))) ;### REMEMBER: P1 AND P1BASICBOOL1ABLE
(GO OUTSTRT))
((AND (SETQ TEM (GET X 'P1BOOL1ABLE))
(NOT (ATOM TEM)))
(COMTP F TEM () 'T 'T)
(GO RET-NO))
((EQ X 'SET)
(COMSET Y) ;Leaves ARG in 1
(GO RET))
((MEMQ X '(ROT LSH ASH FSC))
(RETURN (COMSHIFTS X Y)))
((EQ X 'TYPEP)
(COND (EFFS (SETQ F (CADR F)) (GO A)))
(COMTP F () () 'T 'T)
(GO RET-NO))
((EQ X 'ARG)
(SETQ UNSAFEP (NOT #%(NUMACP-N ARGNO)))
(SETQ VALAC (COMARG Y))
(GO RETV))
((EQ X '*THROW)
#%(LET (EFFS (ARGNO 2) PNOB (HLAC 0))
(SETQ TEM (COMP0 (CAR Y))
ARGNO 1
T1 (COMP0 (CADR Y))
HLAC 2)
(LOADAC TEM 2 'T) ;The tag name
(LOADAC T1 1 'T)) ;The value
#%(CLEARALLACS)
(OUTPUT '(JRST 0 (ERUNDO -1)))
(GO RET))
((EQ X 'PLIST)
(SETQ VALAC (COMPLIST Y))
(GO RETV))
((MEMQ X '(RPLACX CXR))
(SETQ VALAC (COM-X-C-R X Y))
(GO RETV))
((EQ X 'SFA-CALL)
(LOADACS (ITEML Y () ) 3 () )
#%(CLEARALLACS)
(OUTPUT '(MOVEI TT SFCALI))
(OUTPUT '(XCT 0 @ 1 1))
(GO RETV))
((EQ X 'MUNKAM)
(SETQ UNSAFEP 'T)
(SETQ VALAC (COMMUNKAM Y))
(GO RETV))
((MEMQ X '(EXAMINE DEPOSIT))
(SETQ VALAC (COMEX-DP X Y))
(GO RETV)) ))
((EQ T1 'JSP)
(SETQ JSP (GET X 'JSP))
(AND (EQ X 'CONS)
(QNILP (CADR Y))
(SETQ X 'NCONS
Y (LIST (CAR Y))
JSP (GET X 'JSP)))
(SETQ T1 (COND ((CDR JSP) ;CONS, NCONS
'((PNOB PNOB PNOB PNOB PNOB) ; and XCONS
() PNOB PNOB PNOB PNOB PNOB))
('(( T T T T ) () T T T T )))) ;%HUNKn
(GO LDARGS))
((MEMQ T1 '(EXPR *EXPR)) ) ;Normal case - Do nothing
((MEMQ T1 '(*LEXPR LSUBR)) ;Compile L-type form
(COND ((EQ X PROGN) (PROG2 (REMOVE (SETQ Z (COMPROGN Y EFFS))) (RETURN Z)))
((EQ X 'PROG2)
(COMPE (CAR Y))
(SETQ T1 (COMP0 (CADR Y)))
(MAPC 'COMPE (CDDR Y))
(REMOVE T1)
(RETURN T1))
((AND (EQ X 'BOOLE) (EQ (CAAR Y) 'QUOTE)) (RETURN (COMBOOLE Y)))
((AND (EQ X 'PRINC)
(NOT (ATOM (CAR Y)))
(EQ (CAAR Y) 'QUOTE)
(STRTIBLE (CADAR Y)))
(GO OUTSTRT)))
(SETQ VALAC (COMLC X Y () ))
(GO CALLX))
((EQ T1 '*FEXPR) #%(NO-DELAYED-SPLDS) (GO F-FORM))
('T (GO LOSTF)))) ;*FEXPR should be case left
((SETQ ARRAYP (GET X '*ARRAY))
(COND ((AND ARRAYOPEN (NOT (EQ ARRAYP 'T)))
(SETQ VALAC (COMARRAY X Y ARRAYP () ))
(GO RET))))
((EQ X GOFOO) ;Hac for MAP series
((LAMBDA (AC)
(OUTPUT '(PUSH P (% 0 0 '())))
(PUSH (LIST (CAR Y)) REGPDL)
(OUTPUT (CONS 'MOVEI (CONS AC '(0 P))))
(CONT AC (LIST (CADR Y))))
(FRAC1))
(SETQ OLVRL (DELQ (CAR Y) (DELQ (CADR Y) OLVRL)))
(GO RET))
('T (GO LOSTF) ))
(SETQ T1 (OR (GET X 'NUMFUN) (FUNMODE X)))
LDARGS ;Compile for normal EXPR or SUBR type
(COND ((OR (NULL SPLDLST)
(NULL LDLST)
ARRAYP
JSP
(AND (GET X 'ACS) (NOT (EQ (GET X 'NOTNUMP) 'EFFS)))
(NULL (FLUSH-SPL-NILS)))
(SETQ Z (ITEML Y T1))
(SETQ TEM () )
(COND ((AND (CDR Y) ;Commutative 2-arg function
(NULL (CDDR Y)) ;2nd arg in acc 1, but
(NULL ARRAYP)
(SETQ TEM (GET X 'COMMU)) ; first arg not in ac
(EQUAL (ILOC0 (CAR Z) () ) 1)
(NOT (EQUAL (ILOC0 (CADR Z) () ) 1)))
(SETQ Z (REVERSE Z))
(SETQ X TEM)
(AND JSP (SETQ JSP (GET X 'JSP))))))
('T #%(NO-DELAYED-SPLDS) ;Spec var and carcdr loads
(SETQ Z (ITEML Y T1))))
(LOADACS Z (SETQ NARGS (LENGTH Z)) T1)
CALL ;Output a "CALL" to the function
(COND ((NULL JSP)
(CLEARACS1 X () )
(SETQ VALAC (OUTFUNCALL 'CALL NARGS X)))
('T (COND ((NULL (CDR JSP)) (SETQ JSP (CAR JSP))) ;%HUNKn cases
('T (SETQ JSP (COND ((NOT (UNSAFEP (CAR REGACS)))
(CAR JSP)) ;4-way split depending
((CDR JSP)))) ; on safety of args
(COND ((EQ JSP 'PUNT) (SETQ JSP () ) (GO CALL))) ;punt this case, do CALL
(SETQ JSP (COND ((OR (NULL (CDR JSP)) ;dont check 2nd arg on
(NOT (UNSAFEP (CADR REGACS))));1-arg functions
(CAR JSP))
((CDR JSP))))))
(CLEARACS1 X () )
(OUTPUT JSP)))
CALLX (AND CCSLD (DIDUP CLPROGN)) ;Delete IDUPS if CSLD was called
(AND UNSAFEP (BARF () |UNSAFEP after "CALL" - COMPFORM|))
(AND (OR CCSLD
(AND (NOT JSP)
(SYMBOLP X)
(OR (NOT (GET X 'ACS))
(NOT (EQ (GET X 'NOTNUMP) 'NOTNUMP)))))
(CARCDR-FREEZE () () )) ;Freeze carcdrings if unsure
RETV (COND (EFFS (CONT VALAC () ) (RETURN () )))
RET (COND (EFFS (RETURN () ))
('T (SETQ Z (LIST (GENSYM)))
(AND (AND UNSAFEP (NOT #%(NUMACP-N VALAC)))
(PUTPROP (CAR Z) 'T 'UNSAFEP))
(CONT VALAC Z)
(RETURN Z)))
RET-NO (SETQ VALAC ARGNO)
(GO RETV)
F-FORM (CPUSH 1)
(OUT1 'MOVEI 1 (LIST 'QUOTE Y))
(CONT 1 () )
F-* (SETQ NARGS 15.) ;15. Indicates F-type CALL
(GO CALL)
OUTSTRT
(SETQ T1 (COND ((NULL (CDR Y)) 0)
((EQ (CAR (SETQ T1 (COMP (CADR Y)))) 'MSGFILES)
(REMOVE T1)
15.)
((LOADINREGAC T1 'FRACB () ))))
(COND ((SYMBOLP (SETQ Y (CADAR Y))))
('T (SETQ Y (MAKNAM (EXPLODEN Y)))))
(COND (USE-STRT7
#%(OUTFS 'STRT7 T1 `(% ASCII ,y)))
('T #%(OUTFS 'STRT T1 `(% SIXBIT ,(6bstr y)) )))
(RETURN '(QUOTE T))
LOSTF (BARF X |Lost function - COMPFORM|) ))
(COMMENT COMABSMINUS and COMARITH)
(DEFUN COMABSMINUS (FUN ARG)
((LAMBDA (OP ARG AC TYPE LARG)
(SETQ LARG (ILOCMODE ARG 'FREENUMAC TYPE))
(REMOVE ARG)
(COND ((AND (NOT ATPL)
(EQ (CAR LOUT) 'MOVE)
#%(NUMACP LARG)
(NOT (DVP LARG))
(NUMBERP (CADR LOUT))
(= (CADR LOUT) LARG))
(RPLACA LOUT (CAR OP))
(SETQ AC LARG))
('T (COND (#%(NUMACP LARG)
(SETQ AC LARG)
(CPUSH LARG)
#%(OUTFS (COND ((EQ (CAR OP) 'MOVN) 'MOVNS) ('MOVMS))
0
LARG))
('T (OUT3 OP (SETQ AC (FREENUMAC)) LARG)))))
(SETMODE AC TYPE)
(CAR (CONT AC (LIST (GENSYM)))))
(COND ((EQ FUN 'MINUS) '(MOVN)) ((EQ FUN 'ABS) '(MOVM)))
(COMPW (CADR ARG) () #%(NUMVALAC))
0
(CAR ARG)
() ))
(DEFUN COMAD1SB1 (FUN ARG)
((LAMBDA (AC N)
(AND (EQ (CAR ARG) 'FLONUM) (SETQ N (+ N 2)))
(AND (EQ FUN 'SUB1) (SETQ N (1+ N)))
(OUTPUT (A1S1A (- AC #%(NUMVALAC)) N))
(SETMODE AC (CAR ARG))
(CAR (CONT AC (LIST (GENSYM)))))
(LOADINSOMENUMAC (COMPW (CADR ARG) () #%(NUMVALAC)))
0))
(DEFUN COMARITH (FUN LL)
((LAMBDA (MIXP TYPEL ARGL)
(SETQ TYPEL (COND ((NULL (CAR LL)) (CAR COMAL))
((EQ (CAR LL) 'FIXNUM) (CADR COMAL))
((EQ (CAR LL) 'FLONUM) (CADDR COMAL))
('T (SETQ MIXP (MEMQ '() (CAR LL))) (CAR LL))))
(SETQ ARGL ((LAMBDA (ARGNO EFFS PNOB TEM)
(MAPCAR '(LAMBDA (ARG TYPE)
(COND (TYPE
(FREEIFYNUMAC)
(SETQ ARGNO #%(NUMVALAC))
(SETQ ARG (COMP0 ARG))
(AND (NOT (EQ (CAR ARG) 'QUOTE))
(SETQ TEM (ASSQ (CAR ARG) NUMACS))
(NULL (GETMODE0
(- #.(+ (NUMVALAC) (NUMNACS))
(LENGTH (MEMQ TEM NUMACS)))
'T
() ))
(NUMODIFY ARG TYPE))
ARG)
('T (SETQ ARGNO 1)
(COMP0 ARG))))
(CDR LL)
TYPEL))
#%(NUMVALAC) () () () ))
(COND ((OR (EQ TYPEL (CAR COMAL)) MIXP)
(CAR (CONT (COMLC FUN ARGL 'T) (LIST (GENSYM)))))
((PROG (ARG1 ARG2 OP AC AD MODE)
(SETQ AC 0 MODE (CAR TYPEL))
(SETQ OP (CDR (ASSQ FUN (COND ((EQ MODE 'FIXNUM)
'((PLUS ADD) (DIFFERENCE SUB)
(TIMES IMUL) (QUOTIENT IDIV)))
('T '((PLUS FADR) (DIFFERENCE FSBR)
(TIMES FMPR) (QUOTIENT FDVR)))))))
(REMOVE (SETQ ARG1 (CAR ARGL)))
A (AND (NULL (SETQ ARGL (CDR ARGL))) (RETURN ARG1))
(COND ((CDR TYPEL) (SETQ TYPEL (CDR TYPEL))))
(SETQ ARG2 (CAR ARGL))
(COND ((NOT (EQ MODE (CAR TYPEL)))
(COND ((EQ MODE 'FIXNUM)
(SETQ ARG1 (COMFIXFLT ARG1 (SETQ MODE 'FLONUM)))
(SETQ OP (CDR (ASSQ (CAR OP) '((ADD FADR) (SUB FSBR)
(IMUL FMPR) (IDIV FDVR))))))
('T (PUSH ARG1 LDLST)
(PUSH (SETQ ARG2 (COMFIXFLT ARG2 'FLONUM)) LDLST)))))
(COND ((AND (MEMQ FUN '(PLUS TIMES))
(NOT #%(ACLOCP (ILOC0 ARG1 MODE)))
#%(ACLOCP (SETQ AD (ILOC0 ARG2 MODE))))
(REMOVEB ARG2)
(CPUSH (SETQ ARG2 ARG1 AC AD)))
((EQ (CAR OP) 'IDIV)
(SETQ AD ((LAMBDA (TAKENAC1) (FREENUMAC))
#.(+ (NUMVALAC) (NUMNACS) -1)))
(SETQ AC (LOADINNUMAC ARG1 AD () 'REMOVEB))
(COND ((= AC #.(+ (NUMVALAC) (NUMNACS) -1))
(LOADAC ARG1 AD () )
(CONT AC () )
(SETQ AC AD))))
('T (SETQ AC (LOADINSOMENUMAC ARG1))))
(COND ((AND (EQ FUN 'TIMES) ;TRAP FOR MUL BY POWER OF 2
(EQ MODE 'FIXNUM)
(QNP ARG2)
#%(/2^N-P (CADR ARG2)))
(REMOVE ARG2)
(COND ((> (CADR ARG2) 1)
#%(OUTFS 'ASH AC (1- (HAULONG (CADR ARG2)))))
((= (CADR ARG2) 0) #%(OUTFS 'MOVEI AC 0)))
(GO B)))
(SETQ AD ((LAMBDA (TAKENAC1) #%(ILOCNUM ARG2 'FREENUMAC)) AC))
(REMOVEB ARG2)
(COND ((EQ (CAR OP) 'IDIV)
((LAMBDA (II)
(AND (CPUSH-DDLPDLP II AD) ;LEAVES SLOTX SET AT II
(SETQ AD (1- AD)))
(RPLACA SLOTX () )
(SETMODE AC () ))
(1+ AC)))
((AND #%(ACLOCP AD) (= AD #.(NUMVALAC)) (MEMQ FUN '(PLUS TIMES)))
(SETQ AD AC AC #.(NUMVALAC))))
(AND (CPUSH-DDLPDLP AC AD) (SETQ AD (1- AD)))
(OUT3 OP AC AD)
B (SETMODE AC MODE)
(SETQ ARG1 (CAR (CONT AC (LIST (GENSYM)))))
(GO A)))))
() () () ))
(COMMENT COMARRAY)
(DEFUN COMARRAY (X Y FORM MODE)
(SETQ Y (NREVERSE
(ITEML Y (COND ((AND FORM (SETQ Y (GET X 'NUMFUN))) (SETQ MODE (CADR Y)) Y)
(#%(NCDR '(FIXNUM FIXNUM FIXNUM FIXNUM FIXNUM FIXNUM FIXNUM)
(- 5 (LENGTH Y))))))))
(COM-AREF X Y () MODE FORM))
(DEFUN COM-AREF (X Y STORE MODE FORM)
;Compile for array references
(PROG (LOC ADDR ACX SVSLT FLAG TAKENAC1 ACLQ PARITY II)
(DECLARE (FIXNUM PARITY))
(SETQ TAKENAC1 0 PARITY 0)
(SETQ LOC (COND ((AND (NOT EFFS) (NOT #%(NUMACP-N ARGNO))) ARGNO)
(STORE (FRAC1))
((FRAC5))))
(COND ((AND (NULL MODE) STORE)
(SETQ ADDR #%(ILOCREG STORE LOC))
(REMOVS STORE)
(SETQ STORE (MAKESAFE STORE ADDR () ))))
(SETQ ADDR
(CONS '@
(COND ((NULL FORM) ;FORM=() => "ARRAYCALL" TYPE
(SETQ ACLQ (LIST (GENSYM))
ACX (COND ((OR MODE (NOT STORE))
(LOADINREGAC X
LOC
(ILOCMODE X LOC () )))
((LOADINREGAC X 'FRAC5 () )))
SVSLT (FIND ACX))
(RPLACA SVSLT ACLQ)
(PUSH ACLQ LDLST)
(LIST 1 ACX))
('T (SETQ FORM (COND ((EQ FORM 'T) () )
((CDR FORM))))
(LIST (LIST 'ARRAY X))))))
(COND ((NULL (CDR Y))
(COND ((AND STORE
MODE
(NOT (EQ (CAR STORE) 'QUOTE))
(SETQ FLAG (ILOC2 (VARBP (CAR STORE)) STORE MODE))
(NUMBERP FLAG)
(= FLAG #%(NUMVALAC))
(NOT (ZEROP (FREENUMAC1))))
(SETQ TAKENAC1 #%(NUMVALAC)
FLAG (CAR #%(ACSSLOT #%(NUMVALAC)))
SVSLT (CAR #%(ACSMODESLOT #%(NUMVALAC)))
LOC (LOADINSOMENUMAC (CAR Y))
TAKENAC1 0)
(OUT1 'EXCH LOC #%(NUMVALAC))
(CONT LOC FLAG)
(SETMODE LOC SVSLT)
(SETQ FLAG () )
#%(NULLIFY-NUMAC))
((QNP (CAR Y)) (REMOVE (CAR Y)) (SETQ FLAG (CADAR Y)))
('T (LOADAC (CAR Y) #%(NUMVALAC) (SETQ FLAG () )))))
('T (PROG (N D)
(SETQ N 0 TAKENAC1 #%(NUMVALAC))
(COND ((AND FORM
(DO ((ZZ FORM (CDR ZZ)) (Z Y (CDR Z)))
((NULL Z) (SETQ FLAG 'T))
(COND ((AND (QNP (CAR Z))
(FIXP (SETQ ACX (CADAR Z)))
(COND ((FIXP (SETQ D (CAR ZZ))))
((EQ Y Z) (SETQ D 0) 'T)))
(SETQ N (+ (* D N) ACX))) ;Dimensionality and particular index
((EQ Y Z) (RETURN () )) ;combined when both are constant
('T (MAPC 'REMOVE (LSUB Y Z))
(COND ((FIXP (CAR ZZ))
(SETQ N (* N (CAR ZZ))
FORM (CONS () (CONS CLPROGN (CDR ZZ)))
Y (CONS () Z)))
('T (SETQ Y (CONS (LIST 'QUOTE N) Z)
FORM (CONS () ZZ))))
(SETQ FLAG () )
(RETURN 'T)))))
(SETQ PARITY (COND ((ODDP N) -1) (1)))
(COND (FLAG (MAPC 'REMOVE Y) ;Here, FLAG=T signals
(SETQ FLAG N) ;a constant linearized index
(RETURN () ))
((AND (NULL (CAR Y)) (NULL (CDDR Y)))
(SETQ PARITY 0) ;PARITY has been lost here
(LOADAC (CADR Y) #%(NUMVALAC) () )
(AND (NOT (ZEROP N)) ;Note that FLAG = ()
#%(OUTFS 'ADDI #%(NUMVALAC) N))
(RETURN () ))
('T (CPUSH #%(NUMVALAC))
(SETQ TAKENAC1 (SETQ ACX (FREENUMAC)))
#%(OUTFS 'MOVEI ACX N))))
('T (SETQ FLAG 'T)))
(SETQ N (1- (LENGTH Y)))
;At this point, FLAG=() signals a partial index calcualtion has been done
(COND ((NULL FLAG))
('T (SETQ ACX (LOADINSOMENUMAC (CAR Y)))
(AND (NOT (= ACX #%(NUMVALAC))) (CPUSH #%(NUMVALAC)))
(CONT ACX () )
(SETQ TAKENAC1 ACX)))
A (COND ((AND FORM (SETQ FORM (CDR FORM)) (FIXP (CAR FORM)))
(SETQ II (CAR FORM))
(AND (NOT MODE) (NOT (ODDP II)) (SETQ PARITY 1))
(COND (#%(/2^N-P II) #%(OUTFS 'ASH ACX (1- (HAULONG II))))
('T (OUT2 '(IMUL) ACX (LIST (LIST 'QUOTE (CAR FORM)))))))
((OR (NULL FORM) (NOT (EQ (CAR FORM) CLPROGN)))
(AND (NOT MODE) (MINUSP PARITY) (SETQ PARITY 0))
(COND ((= ACX #%(NUMVALAC))
(SETQ ACX (FREENUMAC))
(RPLACA SLOTX () ) ;FREENUMAC leaves SLOTX at AC slot
#%(OUTFS 'MOVEI ACX 0 #%(NUMVALAC))
(SETQ TAKENAC1 ACX)))
(OUTPUT (BOLA N 4)) ;"(MOVNI 7 N)"
#%(NULLIFY-NUMAC)
(AND ACLQ
(NOT (EQ ACLQ (CAR SVSLT)))
(SETQ ADDR (ACLQ-FIND ACLQ () )
SVSLT (FIND (CADDR ADDR))))
(OUTPUT (CONS 'IMUL (CONS ACX ADDR)))))
(COND ((CDR (SETQ Y (CDR Y)))
(COND (MODE)
((QNP (CAR Y))
(AND (ODDP (SETQ II (CADAR Y))) (SETQ PARITY (- PARITY))))
('T (SETQ PARITY 0)))
(AREF-ADD (CAR Y) ACX) ;"(ADD ACX LOC[(CAR Y)])"
(SETQ N (1- N))
(GO A))
('T (COND ((QNP (CAR Y))
(AND (NOT MODE) (ODDP (SETQ II (CADAR Y))) (SETQ PARITY (- PARITY)))
(REMOVE (CAR Y))
#%(OUTFS 'MOVEI #%(NUMVALAC) (CADAR Y) ACX))
((PROG2 (SETQ PARITY 0) (= ACX #%(NUMVALAC)))
(AREF-ADD (CAR Y) ACX))
('T (LOADAC (CAR Y) #%(NUMVALAC) () )
#%(OUTFS 'ADD #%(NUMVALAC) ACX)))
(CONT ACX () )
(RETURN (SETQ FLAG () )) ))) ;Normal exit leaves FLAG = ()
(SETQ TAKENAC1 0)))
(COND (FLAG (COND ((AND MODE STORE
(NUMBERP (SETQ LOC (ILOC0 STORE MODE)))
(= LOC #.(NUMVALAC)))
(SETQ LOC ((LAMBDA (TAKENAC1) (FREENUMAC))
#%(NUMVALAC)))
(LOADAC STORE LOC () ))) ;Non-null FLAG indicates constant
(CLEARACS -1 'T () ))
('T (PUSH (SETQ FORM (LIST (GENSYM))) LDLST) ;INDEX not yet loaded; null FLAG
(RPLACA NUMACS FORM) ;Means computed index in NUMVALAC
(RPLACA ACSMODE 'FIXNUM)))
(AND MODE (GO NUMARRAY))
SARRAY
(SETQ ACX 'T) ;FLAG on whether or not to look up ACLQ again
(SETQ LOC (COND (STORE (LOADINREGAC STORE 'FRAC5 (ILOC0 STORE () )))
((AND (NOT EFFS) (NOT #%(NUMACP-N ARGNO)))
(SETQ ACX () )
(AND ACLQ (REMOVE ACLQ))
(CPUSH ARGNO)
ARGNO)
('T (FRAC5))))
(AND ACLQ ACX (NOT (EQ ACLQ (CAR SVSLT)))
(SETQ ADDR (ACLQ-FIND ACLQ LOC)
SVSLT (FIND (CADDR ADDR))))
(SETQ ADDR (CONS LOC ADDR))
(COND (FLAG #%(OUTFS 'MOVEI #%(NUMVALAC) (LSH FLAG -1))
(OUTPUT (CONS (COND ((ODDP (SETQ II FLAG)) (COND (STORE 'HRRM) ('HRRZ)))
('T (COND (STORE 'HRLM) ('HLRZ))))
ADDR)))
('T (REMOVE FORM)
(COND ((ZEROP PARITY)
(OUTPUT #.(SUBST (NUMVALAC) 'AC ''(ROT AC -1)))
(OUTPUT #.(SUBST (NUMVALAC) 'AC ''(JUMPL AC (* 3))))
(OUTPUT (CONS (COND (STORE 'HRLM) ('HLRZ)) ADDR))
(OUTPUT '(JUMPA 0 (* 2)))
(OUTPUT (CONS (COND (STORE 'HRRM) ('HRRZ)) ADDR))
#%(|Oh, FOO!|))
('T (COND ((OR ATPL ATPL1
(NOT (EQ (CAR LOUT) 'MOVEI))
(COND ((EQ (CAR LOUT1) 'ASH) () )
((EQ (CAR LOUT1) 'IMULI) (ODDP (CADDR LOUT1))))
(NOT (= (CADDDR LOUT) (CADR LOUT1))))
(OUTPUT #.(SUBST (NUMVALAC) 'AC ''(ROT AC -1))))
('T (RPLACA (CDDR LOUT1)
(COND ((EQ (CAR LOUT1) 'ASH) (1- (CADDR LOUT1)))
('T (// (CADDR LOUT1) 2))))
(RPLACA (CDDR LOUT) (// (CADDR LOUT) 2))))
(OUTPUT (COND ((PLUSP PARITY) (CONS (COND (STORE 'HRLM) ('HLRZ)) ADDR))
((CONS (COND (STORE 'HRRM) ('HRRZ)) ADDR))))))))
(GO END)
NUMARRAY
(COND (FLAG #%(OUTFS 'MOVEI #%(NUMVALAC) FLAG)))
(SETQ LOC (COND (STORE ((LAMBDA (TAKENAC1) (LOADINSOMENUMAC STORE))
#%(NUMVALAC)))
('T (COND (#%(NUMACP-N ARGNO) ARGNO) (#%(NUMVALAC))))))
(AND ACLQ (NOT (EQ ACLQ (CAR SVSLT)))
(SETQ ADDR (ACLQ-FIND ACLQ () )
SVSLT (FIND (CADDR ADDR))))
(OUTPUT (CONS (COND (STORE 'MOVEM) ('MOVE)) (CONS LOC ADDR)))
(SETMODE LOC MODE)
(AND (NULL FLAG) (REMOVE FORM))
END
(COND (ACLQ (RPLACA SVSLT () ) (REMOVE ACLQ)))
(RETURN LOC)))
(DEFUN ACLQ-FIND (ACLQ LOC) ;Called only by COM-AREF
((LAMBDA (ACX)
(COND (#%(REGACP ACX))
((NULL LOC) (LOADAC ACLQ (SETQ ACX (FRAC5)) () ))
(((LAMBDA (SVSLT)
(SETQ LOC (CAR SVSLT))
(RPLACA SVSLT '(NIL . TAKEN))
(LOADAC ACLQ (SETQ ACX (FRAC5)) () )
(RPLACA SVSLT LOC))
(FIND LOC))))
(LIST '@ 1 ACX))
(ILOC0 ACLQ () )))
(DEFUN AREF-ADD (ITEM ACX) ;COM-AREF "ADD"
(OUT3 '(ADD) ACX (ILOCMODE ITEM 'FREENUMAC 'FIXNUM))
(REMOVE ITEM))
(DEFUN COMARG (Y)
(PROG (Z)
(COND ((NOT (EQ (CAAR Y) 'QUOTE))
(SETQ Z (COND (#%(NUMACP-N ARGNO) (COMP1 (CAR Y)))
((COMP0 (CAR Y)))))
(AND EFFS (PROG2 (REMOVE Z) (RETURN () )))
(SETQ Z (LOADINSOMENUMAC Z))
#%(OUTFS 'ADD Z 'ARGLOC)
(SETQ Y '((QUOTE 0)))
#%(LET ((TAKENAC1 Z)) (CPUSH ARGNO))
(CONT Z () ))
((NULL (CADAR Y))
(CPUSH ARGNO)
(OUTPUT `(MOVE ,argno
,@(cond (#%(numacp-n argno)
(rplaca #%(acsmodeslot argno) 'FIXNUM)
'(@) ))
(ARGLOC 1) ))
(RETURN ARGNO))
('T (CPUSH ARGNO)
(COND ((SETQ Z (MEMQ ARGLOC REGACS))
(SETQ Z (- (+ 1 #%(NACS)) (LENGTH Z))))
((SETQ Z (MEMQ ARGLOC NUMACS))
(SETQ Z (- (+ #%(NUMVALAC) #%(NUMNACS)) (LENGTH Z))))
('T (CONT (SETQ Z #%(FREACB)) ARGLOC)
#%(OUTFS 'MOVE Z 'ARGLOC)))))
(OUTPUT (COND (#%(NUMACP-N ARGNO)
(RPLACA #%(ACSMODESLOT ARGNO) () )
`(MOVE ,argno @ ,(cadar y) ,z))
(`(HRRZ ,argno ,(cadar y) ,z))))
(RETURN ARGNO)))
(COMMENT COMBOOLE)
(DEFUN COMBOOLE (ARGL)
((LAMBDA (N ARGNO EFFS Y)
(SETQ Y (CAR ARGL))
(COND ((OR (NOT (FIXP (CADR Y))) (< (SETQ N (CADR Y)) 0) (> N 15.))
(DBARF ARGL |Wrong value for operation code of BOOLE|)))
(SETQ ARGL (MAPCAR 'COMP0 (CDR ARGL)))
((LAMBDA (AC ARG1 AD)
(COND ((OR (= N 3) (= N 5) (= N 10.) (= N 12.) (= N 0) (= N 15.))
(COND ((OR (= N 0) (= N 15.))
(SETQ AC (FREENUMAC))
#%(OUTFS (CAR (CBA N)) AC AC))
('T (COND ((OR (= N 3) (= N 12.))
(SETQ ARG1 (CAR (LAST ARGL)))))
(SETQ AC (LOADINSOMENUMAC ARG1))
(COND ((OR (= N 10.) (= N 12.))
(COND ((AND (NOT ATPL)
(EQ (CAR LOUT) 'MOVE))
(RPLACA LOUT (CAR (CBA 10.))))
('T (OUTPUT `(,(car (cba 12.)) ,ac))))))))
(MAPC 'REMOVEB ARGL)
(SETMODE AC 'FIXNUM))
((NULL (CDR ARGL))
#%(WARN (CONS Y ARGL) |Too few args to BOOLE - COMBOOLE|)
(REMOVEB ARG1)
ARG1)
((DO ((ARGL (CDR ARGL) (CDR ARGL)))
((NULL ARGL) ARG1)
(COND ((AND (NOT #%(ACLOCP (ILOC0 ARG1 'FIXNUM)))
#%(ACLOCP (SETQ AD (ILOC0 (CAR ARGL) 'FIXNUM))))
(REMOVEB (CAR ARGL))
(CPUSH AD)
(SETQ AC AD
AD #%(LET ((TAKENAC1 AC))
#%(ILOCNUM ARG1 'FREENUMAC)))
(COND ((OR (= N 2) (= N 13)) (SETQ N (+ N 2)))
((OR (= N 4) (= N 15)) (SETQ N (- N 2))))
(REMOVEB ARG1))
('T (SETQ AC (LOADINSOMENUMAC ARG1))
#%(LET ((TAKENAC1 AC))
(SETQ AD #%(ILOCNUM (CAR ARGL) 'FREENUMAC)))
(REMOVEB (CAR ARGL))))
(COND ((AND (NOT ATPL) (EQ (CAR LOUT) 'MOVE) (EQUAL (CADR LOUT) AD))
(CONT AD () )
(SETQ LOUT (CONS (CAR (CBA N)) (CONS AC (CDDR LOUT)))))
('T (OUT3 (CBA N) AC AD)))
(COND ((CDR ARGL)
;Prepare for next time around loop
(PUSH (SETQ ARG1 (LIST (GENSYM))) LDLST)
(CONT AC ARG1)))
(SETMODE AC 'FIXNUM))))
(CAR (CONT AC (LIST (GENSYM)))))
0 (CAR ARGL) () ))
0 #%(NUMVALAC) () () ))
(COMMENT COMCOND)
(DEFUN COMCOND (Y BTEST F C@LCP)
;;Typical y = (complexity setqlist condunsf mod clause 1 - - clause n)
(AND (AND C@LCP (NOT (GET C@LCP 'LEVEL)))
;PROG tag - make sure that the PRSSL has been set
(CPVRL))
(CLEAR (CADR Y) 'T)
#%(LET ((CEXIT (COND (C@LCP) ((LEVELTAG))))
(EXLDL LDLST)
(CONDPNOB PNOB)
CLZTAG SVSPLDLST TEM ACX LASTCLZP JSP SNILP PNOB)
(COND ((AND (NOT EFFS)
(NOT BTEST)
(NOT (= ARGNO 1))
(> (CAR Y) 1)
(NOT #%(NUMACP-N ARGNO)))
;;A COND for value which is complex enough to warrant
;; switching the valac to 1
(SETQ ARGNO 1)))
(DO ((EXP (CDDDDR Y) (CDR EXP))
(ARGNO ARGNO))
((NULL EXP) () )
(SETQ SNILP 'T)
(SETQ LASTCLZP (NULL (CDR EXP)))
(COND ((OR (NULL (CDAR EXP)) (EQ (CADAR EXP) NULFU))
;COND pair with only one part or like ((NULL EXP) () )
; for value expressed as (EXP NULFU)
(COND (BTEST
(COND ((OR F LASTCLZP (CDAR EXP))
(BOOL1LCK (CAAR EXP) BTEST F))
('T (BOOL1LCK (CAAR EXP) CEXIT 'T)))
(CLEARVARS))
(EFFS
(IF LASTCLZP
(COMPE (CAAR EXP))
(BOOL1LCK (CAAR EXP) CEXIT (NULL (CDAR EXP))))
(CLEARVARS))
((AND (NOT LASTCLZP)
(NULL (CDAR EXP))
#%(NUMACP-N ARGNO))
#%(ILOCF (SETQ TEM (COMPR (CAAR EXP) () 'T 'T)))
(SETQ CLZTAG (LEVELTAG))
(BOOL3 TEM () CLZTAG () )
(LOADAC TEM ARGNO () )
(CLEARVARS)
(OJRST CEXIT () )
(SLOTLISTSET (LEVEL CLZTAG))
(OUTTAG0 CLZTAG))
('T #%(LET ((CONDPNOB PNOB))
(LOADAC (COMP (CAAR EXP))
ARGNO
(NOT CONDPNOB)))
(CLEARVARS)
(AND (NOT LASTCLZP)
(COND ((AND (NULL (CDAR EXP))
(OR #%(NUMACP-N ARGNO)
(AND (NOT ATPL)
(EQ (CAR LOUT) 'JSP)
(MEMQ (CADDR LOUT) '(FXCONS FLCONS)))))
(OJRST CEXIT () ))
('T
(COND ((SETQ TEM (BADTAGP CEXIT))
(SETQ TEM (LEVELTAG))
(OUTJ (COND ((CDAR EXP) 'JUMPN)
('JUMPE))
ARGNO
TEM)
(OJRST CEXIT () )
(SLOTLISTSET (LEVEL TEM))
(OUTTAG0 TEM))
((OUTJ (IF (CDAR EXP)
'JUMPE
'JUMPN)
ARGNO
CEXIT)))))))))
((AND (SETQ TEM (NULL (CDDAR EXP)))
(EQ (CAADAR EXP) 'GO)
(ATOM (CADADR (CAR EXP)))
(EASYGO))
;Like "(EXP (GO FOO))"
(SETQ SNILP (BOOL1 (CAAR EXP) (ADR (CADADR (CAR EXP))) 'T)))
((AND TEM
(EQ (CAADAR EXP) 'RETURN)
(QNILP (CADR (CADAR EXP)))
(EASYGO))
;Like "(EXP (RETURN () ))"
(SETQ SNILP (BOOL1 (CAAR EXP) (GENTAG 'EXITN) 'T)))
((AND (NOT EFFS) ;(COND . . .
(NOT BTEST) ; ((FOO BAR) . . . X)
(COND ((NULL (CDR EXP)) ; (T Y))
(SETQ TEM ''()) ;OR LATTER CLAUSE MIGHT SIMPLY BE
(OR (ATOM (CAAR EXP)) ; (Y), OR BE ABSENT [EG, (T () )]
(P1BOOL1ABLE (CAAR EXP))))
((NULL (CDDR EXP)) ;X MUST BE VAR, OR QUOTED
(SETQ TEM ;Y MUST BE 1INSP
(COND ((NULL (CDR (SETQ TEM (CADR EXP))))
(CAR TEM))
((AND (NULL (CDDR TEM))
(EQ (CAAR TEM) 'QUOTE)
(CADR TEM))
(CADR TEM)))) ;X HELD BY JSP, Y BY TEM
(COND ((NULL TEM) () )
((ATOM TEM) (1INSP TEM))
((MEMQ (CAR TEM) '(QUOTE FUNCTION)))
(#%(NUMACP-N ARGNO) () )
((AND (NOT (ATOM (CAR TEM)))
(EQ (CAAR TEM) CARCDR)
(NULL (CDDAR TEM))
(ATOM (CADR TEM)))))))
(PROG2 (SETQ SVSPLDLST (CDDAR EXP) ACX () ) 'T)
(COND ((ATOM (SETQ JSP (CAR (LAST (CAR EXP)))))
(COND ((NULL (SETQ ACX (1INSP JSP))) () )
((NOT (EQ ACX CLPROGN))
(SETQ ACX () )
'T)
('T (SETQ ACX 'T)
(AND (NULL SVSPLDLST)
(COND ((ATOM TEM) (NOT (VARMODE TEM)))
((QNILP TEM)))))))
((EQ (CAR JSP) 'QUOTE)
(AND (NULL SVSPLDLST)
(COND ((SYMBOLP TEM)
(OR #%(NUMACP-N ARGNO)
(NOT (VARMODE TEM))))
((QNILP TEM)))
(SETQ ACX 'T))
'T)))
(AND ACX (SETQ ACX TEM TEM JSP JSP ACX ACX 'T));ACX=T => INVERTED TEST
(SETQ CLZTAG () )
(CPUSH ARGNO)
(COND ((AND (NULL SVSPLDLST)
(COND ((ATOM (CAAR EXP))
(SETQ SVSPLDLST (CAAR EXP))
'T)
((AND (EQ (CAAAR EXP) 'NULL)
(ATOM (CADAAR EXP)))
(SETQ ACX (NULL ACX) SVSPLDLST (CADAAR EXP))
'T)))
(REMOVE (SETQ SVSPLDLST (COMP0 SVSPLDLST)))
(OUT1 (COND (ACX 'SKIPN) ('SKIPE))
0
#%(ILOCN SVSPLDLST)))
((COND (SVSPLDLST () )
((CCHAK-BOOL1ABLE (CAAR EXP) ACX))
((AND (EQ (CAAAR EXP) 'NULL)
(CCHAK-BOOL1ABLE (CADAAR EXP) (NULL ACX))))))
('T (SETQ CLZTAG (LEVELTAG))
(BOOL1 (CAAR EXP) CLZTAG ACX)
(AND (CDDAR EXP)
(MAPC 'COMPE (CDR (L2F (CDAR EXP)))))
(CLEARVARS)
(RST CLZTAG)))
(REMOVE (SETQ JSP (COMP0 JSP)))
(SETQ JSP (ILOCMODE JSP
ARGNO
(IF #%(NUMACP-N ARGNO)
'(FIXNUM FLONUM)
'(() FIXNUM FLONUM))))
(COND ((OR (AND (SETQ ACX (NUMBERP JSP)) (= ARGNO JSP))
(AND (NULL ACX)
(NULL (CDR JSP))
(EQUAL (CAR JSP) (CONTENTS ARGNO))))
(COND ((AND (NOT CLZTAG)
(NOT ATPL)
(SETQ ACX (GET (CAR LOUT) 'CONV)))
(RPLACA LOUT ACX))
((OUTPUT '(SKIPA)))))
((NOT #%(NUMACP-N ARGNO))
(COND ((AND (NOT ACX) (QNILP (CAR JSP)))
(OUTPUT (BOLA ARGNO 1)))
('T (OUT1 'SKIPA ARGNO JSP))))
((AND (NOT ACX) (NULL (CDR JSP)) (Q0P+0P (CAR JSP)))
#%(OUTFS 'TDZA ARGNO ARGNO))
('T (OUT3 '(SKIPA) ARGNO JSP)))
(COND (CLZTAG
(OUTPUT CLZTAG)
(SETQ SVSPLDLST (LIST REGACS NUMACS ACSMODE))
(SLOTLISTSET (LEVEL CLZTAG))))
(REMOVE (SETQ TEM (COMP0 TEM)))
(COND (#%(NUMACP-N ARGNO)
(OUT3 '(MOVE) ARGNO #%(ILOCNUM TEM ARGNO))
(RPLACA #%(ACSMODESLOT ARGNO) () ))
((PROG2 (SETQ JSP LOUT ACX #%(ILOCREG TEM ARGNO))
(COND ((NOT (NUMBERP ACX)) (SETQ JSP 'T))
((NOT (= ACX ARGNO))
(SETQ JSP () )
(AND (REGADP ACX) (SETQ JSP 'T))
'T)))
(OUT1 (COND (JSP 'MOVE)
('T (AND #%(NUMACP ACX)
(OR (NOT (EQ (CDR (CONTENTS ACX)) 'DUP))
(PROG2 (CONT ACX () )
()
(SETQ ACX #%(ILOCNUM TEM () )))
(NOT #%(PDLLOCP ACX)))
(BARF TEM |Lost skip hac - CCMOD|))
'MOVEI))
ARGNO
ACX))
((OR (NOT (EQ JSP LOUT))
(AND (NOT ATPL) (EQ (CAR LOUT) 'JRST)))
() )
('T ((LAMBDA (INST)
(COND ((OR (COND (CLZTAG ATPL1) (ATPL))
(NOT (MEMQ (CAR INST) '(TDZA SKIPA))))
(BARF INST |Sussman loses - CCMOD|))
((EQ (CAR INST) 'TDZA)
(SETQ INST (CONS 'SETZM (CONS '0 (CDDR INST)))))
('T (SETQ INST (CONS 'MOVE (CDR INST)))))
(COND (CLZTAG (SETQ LOUT1 INST))
('T (SETQ LOUT INST))))
(COND (CLZTAG LOUT1) (LOUT)))))
#%(|Oh, FOO!|)
(AND CLZTAG (ACSMRGL SVSPLDLST))
(SETQ SNILP 'T)
(AND (CDR EXP) (SETQ EXP (CDR EXP))))
('T (SETQ CLZTAG (LEVELTAG))
(COND ((AND BTEST (NULL F) LASTCLZP)
(BOOL1LCK (CAAR EXP) BTEST () ))
((AND EFFS LASTCLZP)
(BOOL1LCK (CAAR EXP) CEXIT () ))
((BOOL1 (CAAR EXP) CLZTAG () )))
(SETQ SVSPLDLST (APPEND (FLUSH-SPL-NILS) () ))
(SETQ ACX () )
(COMPROGN (CDR (SETQ TEM (L2F (CDAR EXP)))) 'T)
(COND ((EQ (CAAR TEM) 'COND)
(RST CEXIT)
#%(LET ((PNOB CONDPNOB))
(COMCOND (CDAR TEM) BTEST F CEXIT)))
(BTEST (BOOL1 (CAR TEM) BTEST F))
(EFFS (COMPE (CAR TEM)))
('T (SETQ ACX ARGNO)
(SETQ TEM #%(LET ((PNOB CONDPNOB))
(COMP0 (CAR TEM))))
(COND ((OR (NOT (QNILP TEM))
(AND (NOT (QNILP (CONTENTS ACX)))
(COND ((NOT LASTCLZP))
((SETQ SNILP () )))))
(LOADAC TEM ACX (NOT CONDPNOB)))
((REMOVEB TEM)))))
(COND ((NOT (SETQ JSP (AND (NOT ATPL) (EQ (CAR LOUT) 'JRST))))
(CLEARVARS)
(COND ((OR (NOT LASTCLZP)
(AND SNILP
(NOT EFFS)
(NOT BTEST)
(GET CLZTAG 'USED)
(SNILPTST CLZTAG)))
(SETQ SNILP () )
(OJRST CEXIT ACX))
('T (RST CEXIT)))))
#%(|Oh, FOO!|)
(SETQ SPLDLST SVSPLDLST)
(SETQ TEM (COND ((COND ((NOT LASTCLZP))
((GET CLZTAG 'USED)
(AND SNILP
(NOT EFFS)
(NOT BTEST)
(SNILPTST CLZTAG)
(SETQ SNILP () ))
'T))
(OUTTAG0 CLZTAG)
(LEVEL CLZTAG))
((AND (NOT C@LCP) (GET CEXIT 'USED))
(COND ((NOT (EQ (SETQ TEM (LEVEL CEXIT)) PRSSL)) TEM)
((MAPCAR '(LAMBDA (X) (APPEND X () )) TEM))))))
(COND ((NULL TEM))
((AND LASTCLZP (NOT JSP) (NOT C@LCP))
(ACSMRGL TEM))
('T (SLOTLISTSET TEM))))))
(COND (BTEST (COND ((AND (NOT F) (NOT SNILP)) (OJRST BTEST () ))))
((AND (NOT EFFS) (NOT SNILP)) (OUT1 'MOVEI ARGNO '(QUOTE () ))))
(SETQ CNT (PLUS CNT 2))
(COND (C@LCP)
((OUTTAG CEXIT))
('T (CLEARVARS) (RST CEXIT)))
(DIDUP (CADR Y))))
(DEFUN SNILPTST (CLZTAG)
(NOT ((LAMBDA (REGACS) (QNILP (CONTENTS ARGNO))) (CAR (LEVEL CLZTAG)))))
(DEFUN CCHAK-BOOL1ABLE (EXP ACX)
(AND (P1BASICBOOL1ABLE EXP)
(NOT (MEMQ (CAR EXP) '(SIGNP NULL PROG2)))
((LAMBDA (PROP)
(COND ((NOT (AND (EQ PROP 'NUMBERP)
(MEMQ (CAR EXP) '(GREATERP LESSP)) ;LIMIT GREATERP AND
(AND (CDDDR EXP) (NULL (CDDDDR EXP))))) ; LESSP TO TWO ARGS
(COND ((MEMQ (CAR EXP) '(EQ EQUAL))
(COMEQ (CDR EXP) () ACX))
((MEMQ (CAR EXP) '(GREATERP LESSP))
(COMGRTLSP EXP () ACX))
((MEMQ (CAR EXP) '(ZEROP PLUSP MINUSP ODDP))
(COMZP EXP () ACX))
((MEMQ PROP '(T NUMBEREP))
(BARF EXP |Lost in CCHAK-BOOL1ABLE|))
('T (COMTP EXP PROP () ACX () )))
'T)))
(GET (CAR EXP) 'P1BOOL1ABLE))))
(COMMENT COMEQ)
(DEFUN COMEQ (EXP TAG F)
; Compile EQ. JRST to TAG (or SKIP one instruction) when sense is normal
; (normal sense signalled by non-null F)
; Return non-null iff JUMP to TAG is being outputted by COMEQ
(PROG (X Y Y/' LX LY AC TYPEL TYPX TYPY TEMP N)
(SETQ N 1)
(SETQ TYPEL (SETQ TYPY (SETQ TYPX (POP EXP))))
(COND (TYPEL
(AND (NOT (MEMQ TYPEL '(FIXNUM FLONUM)))
(SETQ TYPX (CAR TYPEL) TYPY (CADR TYPEL)))
(SETQ TEMP (OR (AND (EQ TYPX 'FIXNUM)
(OR (Q0P+0P (SETQ X (CAR EXP)))
(Q1P+1P-1P X)))
(AND (EQ TYPY 'FIXNUM)
(OR (Q0P+0P (SETQ Y (CADR EXP)))
(Q1P+1P-1P Y)))))))
(COND ((AND TEMP TAG)
(AND (NOT Y) (SETQ X (CADR EXP)))
(SETQ AC (LOADINSOMENUMAC (COMPW X () #%(NUMVALAC))))
(AND (NOT (= TEMP 0)) (SETMODE AC () ) (CONT AC () ))
(OUTJ (COND ((= TEMP 0) (COND (F 'JUMPE) ('JUMPN)))
((< TEMP 0) (COND (F 'AOJE) ('AOJN)))
('T (COND (F 'SOJE) ('SOJN))))
AC
TAG)
(RETURN 'T)))
(NUMODIFY (SETQ X (COMPW (CAR EXP) () (COND (TYPX #%(NUMVALAC)) (1)))) TYPX )
(SETQ Y (COMPW (CADR EXP) () (COND (TYPY (FREENUMAC))
((AND (NULL TYPX)
(NOT EFFS)
(EQUAL 1 (ILOC0 X () )))
ARGNO)
(1))))
; Possibly LY = 1 but Y = (SPECIAL FOO) or (QUOTE FOO)
; will cause LX to become 1
(SETQ LY (ILOCMODE Y (COND (TYPY 'FREENUMAC) ('FRACF)) TYPY))
(SETQ LX (ILOCMODE X (COND (TYPX 'FREENUMAC) ('FRACF)) TYPX))
(COND ((OR (AND TYPEL (NOT (ATOM X)) (EQ (CAR X) 'QUOTE)
(NUMBERP (CADR X)))
(AND TYPY (NOT TYPX)))
(SETQ TEMP X X Y Y TEMP)
(SETQ TEMP LX LX LY LY TEMP)
(SETQ TEMP TYPX TYPX TYPY TYPY TEMP)))
(COND ((AND #%(ACLOCP LX) (NOT (AND TYPX (REGADP LX))))
(SETQ AC LX)
(AND (NUMBERP LY)
(= LY 1)
(NOT (EQUAL Y (CAR REGACS)))
(SETQ LY (ILOC0 Y () )))
(SETQ Y/' Y)
(REMOVE X))
((AND #%(ACLOCP LY) (NOT (AND TYPY (REGADP LY))))
(SETQ AC LY LY LX Y/' X X Y TEMP TYPX TYPX TYPY TYPY TEMP)
(REMOVE X))
('T (SETQ AC (COND ((NOT TYPX)
(COND ((NOT (DVP1 REGACS 1))
(LOADAC X 1 () ) 1)
('T (LOADINREGAC X () LX))))
((LOADINSOMENUMAC X))))
(SETQ Y/' Y)))
; At this point
; AC contains loc of one arg
; X is internal form of that arg
; LY has loc of other
; Y/' is internal form of arg in LY
(COND (TAG (CLEARVARS)
(COND ((AND #%(PDLLOCP LY)
(PROG2 () 'T
(SETQ TEMP (CDDDR (LEVEL TAG)) N LY)
(SETQ N (LENGTH
(COND ((NOT #%(NUMPDLP-N N))
(PROG2 () (CAR TEMP) (SETQ TEMP REGPDL)))
((NOT #%(FLPDLP-N N))
(PROG2 () (CADR TEMP) (SETQ TEMP FXPDL)))
('T (PROG2 () (CADDR TEMP) (SETQ TEMP FLPDL)))))))
(> LY (CONVNUMLOC (SETQ N (- N (LENGTH TEMP)))
(AND (NOT (REGADP LY)) TYPY))))
(SETQ LY (COND ((NULL TYPY) (FRAC5))
(((LAMBDA (TAKENAC1) (FREENUMAC)) AC))))
(LOADAC Y/' LY () )
(RSTD TAG AC LY))
((AND (RSTD TAG AC 0) (NOT (PLUSP N)))
(SETQ LY (ILOC2 (VARBP (CAR Y/')) Y/' TYPY))))
(REMOVE Y/'))
((NULL TAG)
(REMOVE Y/')
(AND (OR (EQ (PROG2 (FIND ARGNO) (CPUSH1 ARGNO () LY)) 'PUSH)
(EQ (PROG2 (FIND AC) (CPUSH1 AC () LY)) 'PUSH))
#%(PDLLOCP LY)
(SETQ LY (ILOC2 (VARBP (CAR Y/')) Y/' TYPY)))))
(SETQ TEMP (COND (#%(EQUIV F TAG) '(CAMN)) ('T '(CAME))))
(COND (#%(NUMACP-N AC) (OUT3 TEMP AC LY))
((OUT1 (CAR TEMP) AC LY)))
(AND TAG (OUTJ0 'JUMPA 0 TAG 'T () )) ))
(DEFUN NUMODIFY (X TYPX)
(COND ((NULL TYPX) () )
('T (SETQ X (ILOCMODE X 'FREENUMAC TYPX))
(AND #%(NUMACP X) (RPLACA #%(ACSMODESLOT X) TYPX))
X)))
(DEFUN COMEX-DP (X Y)
#%(LET* ((VALAC (COND (#%(NUMACP-N ARGNO) ARGNO) ((FREENUMAC))))
(T1 (COMPW (CAR Y) () VALAC))
TEM Z)
(AND (EQ X 'DEPOSIT) (SETQ Y (COMPW (CADR Y) () #%(NUMVALAC))))
(SETQ T1 (COND ((AND (NOT (EQ (CAR T1) 'QUOTE))
(SETQ Z (ILOCMODE T1 () 'FIXNUM))
(COND (#%(ACLOCP Z) (SETQ TEM (REGADP Z)) 'T)
((NOT (REGADP Z)))))
(REMOVE T1)
Z)
((LOADINNUMAC T1 VALAC () 'REMOVEB))))
(COND ((EQ X 'EXAMINE)
(CPUSH VALAC)
(COND (TEM #%(OUTFS 'MOVE VALAC '@ 0 T1))
('T (OUT1 '(MOVE) VALAC T1)))
(SETMODE VALAC 'FIXNUM))
('T #%(LET ((TAKENAC1 T1)) (SETQ Y (LOADINSOMENUMAC Y)))
(COND (TEM #%(OUTFS 'MOVEM Y '@ 0 T1))
('T (OUT1 '(MOVEM) Y T1)))
(AND (NOT EFFS)
#%(OUTFS 'MOVEI
(SETQ VALAC (COND (#%(NUMACP-N ARGNO) ARGNO) ((FRACB))))
''T)) ))
VALAC))
(COMMENT COMERSET)
(DEFUN COMERSET (FUN Y)
#%(LET ((GOBRKL GOBRKL) (ARGNO 1) (TAG (GENSYM))
ERSTP PASSP CATP RSL V)
(CASEQ FUN (ERRSET (SETQ ERSTP 'T))
(%PASS-THRU (SETQ PASSP 'T))
((*CATCH %CATCHALL CATCH-BARRIER) (SETQ CATP 'T))
('T (BARF FUN |What type frame - COMERSET|)))
(COND ((OR PASSP (AND CATP (EQ FUN '%CATCHALL)))
#%(LET ((FTAG (GENSYM)))
#%(CLEARALLACS)
(COND (CATP #%(OUTFS 'MOVEI T TAG) ; for CATCHALL
(OUTPUT '(JSP TT (ERSETUP -3))))
(PASSP (OUTPUT '(JSP TT PTNTRY)))) ; for PASS-THRU
#%(OUTFS 'JUMPA 0 FTAG)
#%(|Oh, FOO!|)
(AND PASSP (PROG2 (STRETCHPDL LPASST-P+1 () )
(STRETCHPDL LPASST-FXP 'FIXNUM)))
(STRETCHPDL 1 () ) ;For ret addr of POPJ P below
(SETQ RSL (SLOTLISTCOPY))
(LOADAC (COMP1 (CAR Y)) 1 'T)
(RESTORE RSL)
(OUTPUT '(POPJ P))
(OUTPUT FTAG)
(SHRINKPDL 1 () )
(AND PASSP (PROG2 (SHRINKPDL LPASST-P+1 () )
(SHRINKPDL LPASST-FXP 'FIXNUM))) ))
('T (LOADAC (COMP1 (CAR (COND (ERSTP (CDR Y)) (Y)))) 1 'T) ; for CATCH varieties
(CLEARACS 2 'T () )
(CLEARNUMACS)
#%(OUTFS 'MOVEI 2 TAG)
(OUTPUT (CASEQ FUN (ERRSET '(JSP TT ERSETUP))
(*CATCH '(JSP TT (ERSETUP -1)))
(CATCH-BARRIER '(JSP TT (ERSETUP -2))) ))))
(STRETCHPDL LERSTP+1 () )
(SETQ RSL (SLOTLISTCOPY))
(PUSH (CONS (COND (CATP 'CATCH) (FUN)) RSL) GOBRKL)
(SETQ V (COND (ERSTP (COMP0 (COND ((AND EFFS (EQ (CAAR Y) 'NCONS)) ;Value from ERRSET will
(CADAR Y)) ; will generally be
((CAR Y))))) ; in 1 since it is
('T (COMPROGN (CDR Y) EFFS)))) ; of form (NCONS FOO)
(COND ((AND (NOT EFFS) (NOT (EQUAL 1 (ILOC0 V () ))))
(LOADAC V 1 'T)) ; so put it in 1
((NULL EFFS) (REMOVE V)))
(RESTORE RSL)
(AND #%(CLEARALLACS) (BARF () |What got pushed - COMERSET|))
(OUTPUT (COND (ERSTP (AND EFFS (OUTPUT '(MOVEI 1 'T))) ;Break up frame of
'(JRST 0 ERUNDO)) ; ERRSET
(PASSP '(JSP TT PTEXIT)) ; PASS-THRU
(CATP '(JRST 0 (ERUNDO -2))))) ; nearest CATCH
(SHRINKPDL LERSTP+1 () )
(OUTPUT TAG)
(SETQ CNT (+ CNT 2))
(COND (EFFS () )
(T (RPLACA REGACS (SETQ V (LIST (GENSYM)))) V))))
(COMMENT COMFIXFLT and COMHAULONG)
(DEFUN COMFIXFLT (ITEM MODE) ;MODE IS ALWAYS EITHER "FIXNUM" OR "FLONUM"
(COND ((EQ (CAR ITEM) 'QUOTE)
(REMOVE ITEM)
((LAMBDA (TYPE)
(COND ((MEMQ TYPE '(FIXNUM BIGNUM))
(COND ((EQ MODE 'FIXNUM)
(COND ((EQ TYPE 'BIGNUM)
(PDERR (CADR ITEM) |Too big to be FIXNUM|)
(SETQ ITEM '0)))
ITEM)
((LIST 'QUOTE (FLOAT (CADR ITEM))))))
((EQ MODE 'FLONUM) ITEM)
((LIST 'QUOTE (FIX (CADR ITEM))))))
(TYPEP (CADR ITEM))))
('T
#%(LET ((LOC #%(NUMVALAC)))
(DECLARE (SPECIAL LOC))
(COND ((EQ MODE 'FIXNUM)
#%(LET ((TAKENAC1 (+ #%(NUMVALAC) #%(NUMNACS) -1)))
(SETQ LOC (LOADINSOMENUMAC ITEM)))
(AND (> LOC #.(+ 1 (NUMVALAC)))
(LOADAC ITEM (SETQ LOC #%(NUMVALAC)) () ))
(CPUSH (1+ LOC))
(MAPC 'OUTPUT
(CASEQ LOC
(#.(+ 0 (NUMVALAC)) ;to flush the QUOTE
'((MULI #.(NUMVALAC) 256.)
(TSC #.(NUMVALAC) #.(NUMVALAC))
(ASH #.(+ 1 (NUMVALAC)) -163. #.(NUMVALAC))))
(#.(+ 1 (NUMVALAC))
'((MULI #.(+ 1 (NUMVALAC)) 256.)
(TSC #.(+ 1 (NUMVALAC)) #.(+ 1 (NUMVALAC)))
(ASH #.(+ 2 (NUMVALAC)) -163. #.(+ 1 (NUMVALAC)))))
(T (BARF LOC |LOC no good for IFIX - COMFIXFLT|))))
(CONT LOC () )
(SETMODE LOC ())
(SETQ LOC (1+ LOC)))
('T (LOADAC ITEM (SETQ LOC #%(NUMVALAC)) () )
(OUTPUT '(JSP T IFLOAT))))
(SETMODE LOC MODE)
(CAR (CONT LOC (SETQ DATA (LIST (GENSYM)))))))))
(DEFUN COMHAULONG (Y)
((LAMBDA (ARGNO ACX EFFS)
(LOADAC (COMP0 (CADR Y)) ARGNO () )
(SETQ ACX (COND ((= ARGNO #%(NUMVALAC)) (+ 2 #%(NUMVALAC)))
(#%(NUMVALAC))))
(COND ((AND (NOT ATPL)
(EQ (CAR LOUT) 'MOVE)
(FIXP (CADR LOUT))
(= (CADR LOUT) ARGNO))
(SETQ LOUT (CONS 'MOVM (CDR LOUT))))
(#%(OUTFS 'MOVMS 0 ARGNO)))
(CLEARNUMACS)
(MAPC 'OUTPUT
(COND ((AND (= ACX #%(NUMVALAC)) (= ARGNO (1+ #%(NUMVALAC))))
#.(SUBLIS (LIST (CONS 'TT (NUMVALAC)) (CONS 'D (1+ (NUMVALAC))) (CONS 'R (+ 2 (NUMVALAC))))
''((MOVEI TT 36.) (JFFO D (* 2)) (TDZA TT TT) (SUBI TT 0 R))))
((AND (= ACX (+ 2 #%(NUMVALAC))) (= ARGNO #%(NUMVALAC)))
#.(SUBLIS (LIST (CONS 'TT (NUMVALAC)) (CONS 'D (1+ (NUMVALAC))) (CONS 'R (+ 2 (NUMVALAC))))
''((MOVEI R 36.) (JFFO TT (* 2)) (TDZA R R) (SUBI R 0 D))))
((BARF (LIST ARGNO ACX) |Lose lose - COMHAULONG|))))
(SETMODE ACX 'FIXNUM)
(CAR (CONT ACX (LIST (GENSYM)))))
(COND ((= ARGNO #%(NUMVALAC)) (1+ #%(NUMVALAC)))
(#%(NUMVALAC)))
()
()))
(COMMENT COMGO and COMGORET)
(DEFUN COMGO (Y)
(COND ((ATOM (CAR Y))
(COMGORET (ADR (CAR Y)) 0))
('T (CPVRL)
(LOADAC (COMP1 (CAR Y)) 1 'T)
(COMGORET (GENTAG 'VGO) 1))))
(DEFUN COMGORET (TAG AC)
(CPVRL)
(CLEARVARS)
(COND ((EASYGO) (OJRST TAG AC))
('T (CLEARNUMACS)
((LAMBDA (L LDLST CNT)
(MAPC '(LAMBDA (Y) (AND (EQ (CAR Y) 'UNBIND)
(CDR Y)
(SETQ CNT (CDR Y))))
GOBRKL)
(MAPC '(LAMBDA (Y)
(COND ((EQ (CAR Y) 'UNBIND) (OUTPUT '(PUSHJ P UNBIND)))
('T (RESTORE (CDR Y))
(OUTPUT
(COND ((EQ (CAR Y) 'ERRSET) ;For ERRSETs
'(JSP T GOBRK))
((EQ (CAR Y) 'CATCH)
'(JSP T (GOBRK -1))) ;For CATCHs
('(JSP TT PTEXIT)))) ;For PASS-THRU
(SHRINKPDL LERSTP+1 () )))) ; or UNWIND-PROTECT
GOBRKL)
(COND ((NULL L-END-CNT))
((> L-END-CNT CNT) (SETQ CNT L-END-CNT)))
(OJRST TAG AC)
(SLOTLISTSET L))
(SLOTLISTCOPY) PROGP CNT))))
(COMMENT COMGRTLSP)
;;; Chart of how COMGRTLSP works, using LESSP for example
;;; (LESSP A B), which is not 2LONG, and
;;; (LESSP A B C D), which is 2LONG
;;; P1 is the comparison between A and B, P2 between B and C,
;;; P3 between C and D. In the normal sense of the test, the
;;; result is either a JUMP to a TAG, or a SKIP of one instruction.
;;; In the inverted sense, the logical sense of the test is
;;; complemented. The argument "F" is non-null for the normal sense.
;;; Examples for the 2LONG case follow. After it are the
;;; examples for the not-2LONG case.
;;; When TAG is supplied, and there is no level problem with it
;;; Normal Inverted
;;; ---------------- --------------
;;; CAIL P1 CAIL P1
;;; JRST LOSE JRST TAG
;;; CAIL P2 CAIL P2
;;; JRST LOSE JRST TAG
;;; |CAIGE| P3 CAIL P3
;;; JRST TAG JRST TAG
;;; LOSE: . . .
;;; When TAG is supplied, and there is a level problem
;;; Normal Inverted
;;; ---------------- --------------
;;; CAIL P1 CAIL P1
;;; JRST LOSE JRST WIN
;;; CAIL P2 CAIL P2
;;; JRST LOSE JRST WIN
;;; CAIL P3 |CAIGE| P3
;;; JRST LOSE JRST LOSE
;;; [PDL corrections] WIN: [PDL corrections]
;;; JRST TAG JRST TAG
;;; LOSE: ... LOSE: . . .
;;; When no TAG is supplied
;;; Normal Inverted
;;; ---------------- --------------
;;; CAIL P1 CAIL P1
;;; JRST LOSE JRST WIN
;;; CAIL P2 CAIL P2
;;; JRST LOSE JRST WIN
;;; CAIL P3 CAIL P3
;;; LOSE: . . . WIN: SKIPA
;;; For all cases which are not-2LONG
;;; With TAG, normal With TAG, inverted
;;; ---------------- --------------
;;; |CAIGE| P1 CAIL P1
;;; JRST TAG JRST TAG
;;; No TAG, normal No TAG, inverted
;;; ---------------- --------------
;;; CAIL P1 |CAIGE| P1
(DEFUN COMGRTLSP (EXP TAG F)
(PROG (ARGL TYPEL MODE ARG1 ARG2 AC AD OP BTAG CTAG B2F SAVE FL 2LONG)
(SETQ TYPEL (COND ((NULL (CADR EXP)) (SETQ OP 'FIXNUM) '(()) )
((NOT (MEMQ (CADR EXP) '(FIXNUM FLONUM))) (CADR EXP))
((NCONS (SETQ OP (CADR EXP))))))
(SETQ ARGL ((LAMBDA (ARGNO EFFS)
(MAPCAR '(LAMBDA (X)
(SETQ SAVE (COMP0 X))
(NUMODIFY SAVE OP)
SAVE)
(CDDR EXP)))
#%(NUMVALAC) () ))
(SETQ 2LONG (CDDR ARGL))
(COND ((AND TAG
(NOT 2LONG)
(OR (Q0P+0P (SETQ ARG1 (CAR ARGL)))
(Q0P+0P (SETQ ARG2 (CADR ARGL)))))
(SETQ OP (COND ((EQ (CAR EXP) 'LESSP) 'JUMPL)
((EQ (CAR EXP) 'GREATERP) 'JUMPG)
((GO BARF))))
(SETQ ARG2 (COND (ARG2 (REMOVE ARG2) ARG1)
('T (SETQ OP (GET OP 'COMMU))
(REMOVE ARG1)
(CADR ARGL))))
(OUTJ (COND (F OP) ((GET OP 'CONV)))
(LOADINNUMAC ARG2 0 () 'REMOVE)
TAG)
(RETURN 'T)))
(SETQ MODE (CAR TYPEL) ARG1 (CAR ARGL))
(SETQ OP (COND ((EQ (CAR EXP) 'LESSP) 'CAML)
((EQ (CAR EXP) 'GREATERP) 'CAMG)
((GO BARF))))
(SETQ BTAG (COND ((NOT 2LONG)
(AND #%(EQUIV TAG F)
(SETQ OP (GET OP 'CONV)))
TAG)
('T (CLEARVARS) ;REALLY only have to clear out vars
(FREEIFYNUMAC) ; which will be SETQ in this computation
(SETQ CTAG (LEVELTAG))
(COND ((NULL TAG) CTAG)
('T (AND (BADTAGP TAG) (SETQ B2F CTAG))
(COND ((OR F B2F) CTAG)
(TAG)))))))
(DO ((ARGL (CDR ARGL) (CDR ARGL)))
((NULL ARGL))
(SETQ ARG2 (CAR ARGL) TYPEL (OR (CDR TYPEL) TYPEL))
(COND ((NOT (EQ MODE (CAR TYPEL)))
(COND ((EQ MODE 'FIXNUM)
(SETQ ARG1 (COMFIXFLT ARG1 (SETQ MODE 'FLONUM))))
((SETQ ARG2 (COMFIXFLT ARG2 'FLONUM))))))
(COND ((AND (NOT #%(ACLOCP (SETQ AD (ILOCMODE ARG1 'FREENUMAC MODE))))
(PROG2 (SETQ SAVE (ILOCMODE ARG2 'FREENUMAC MODE)) 'T)
(COND (#%(NUMACP SAVE) (REMOVE ARG2) 'T)
((EQ (CAR ARG1) 'QUOTE)
(SETQ SAVE (LOADINNUMAC ARG2 0 () 'REMOVE))
'T)))
(SETQ AC SAVE FL 'T SAVE ARG1))
('T (COND (#%(NUMACP AD)
(SETQ AC AD))
((SETQ AC (LOADINNUMAC ARG1 0 () 'REMOVE))))
(REMOVE ARG1)
((LAMBDA (TAKENAC1) (SETQ AD (ILOCMODE ARG2 'FREENUMAC MODE))) AC)
(SETQ SAVE ARG2 FL () )))
(COND ((OR (NULL 2LONG) (CDR ARGL))) ;Fix up last clause of 2LONGs
((NULL TAG) (SETQ BTAG () )) ; for reversal of condition
((AND F (NULL B2F)) (SETQ BTAG TAG OP (GET OP 'CONV)))
((AND (NULL F) B2F)
(PUTPROP (SETQ BTAG (SETQ CTAG (GENSYM)))
(GET B2F 'LEVEL)
'LEVEL)
(SETQ OP (GET OP 'CONV))))
(COND (TAG (AND (RSTD BTAG AC 0)
(NUMBERP AD)
(SETQ AD (ILOC2 (VARBP (CAR SAVE)) SAVE MODE)))
(REMOVEB SAVE)
(CLEARVARS))
('T (REMOVE SAVE)
(AND (OR (EQ (PROG2 (FIND ARGNO) (CPUSH1 ARGNO () AD)) 'PUSH)
(EQ (PROG2 (FIND AC) (CPUSH1 AC () AD)) 'PUSH))
#%(PDLLOCP AD)
(SETQ AD (ILOC2 (VARBP (CAR SAVE)) SAVE MODE)))))
(OUT3 (ASSQ (COND ((NULL FL) OP) ((GET OP 'COMMU)))
'((CAML) (CAMLE) (CAMG) (CAMGE)))
AC
AD)
(AND BTAG (OUTJ0 'JUMPA 0 BTAG 'T 0))
(SETQ ARG1 ARG2))
(COND (CTAG (SETQ SAVE (SLOTLISTCOPY))
(COND (B2F (AND (NULL F) (OUTTAG B2F))
(OUTJ0 'JRST 0 TAG 'T 0)))
(SLOTLISTSET (LEVEL CTAG))
(SETQ REGACS (CAR SAVE) ;This is half a
NUMACS (CADR SAVE) ; SLOTLISTSET
ACSMODE (CADDR SAVE))
(OUTTAG0 CTAG)
(AND (NULL TAG) (NULL F) (OUTPUT '(SKIPA)))))
(RETURN () )
BARF (BARF EXP |This is no fun - COMGRTLSP|)))
(COMMENT COMLAMAP)
(DEFUN COMLAMAP (FORM)
;;; FORM = ((LAMBDA complexity setqlist (specvars modelist ignorevars)
;;; lamvars body endcount lamunsf nlnvthtbp)
;;; arg1 arg2 ... argn)
#%(LET ((OLVRL OLVRL) (BVARS BVARS) (GOBRKL GOBRKL) (MODELIST)
(CONDPNOB PNOB) (LLL (CDDAR FORM))
SPECVARS IGNOREVARS LARG SPFL LMRSL MODE TEM Y PNOB ITEM SETQLIST)
(POP LLL SETQLIST)
(POP LLL MODELIST)
#%(DESETQ (SPECVARS MODELIST IGNOREVARS) MODELIST)
(CLEAR SETQLIST () ) ;Check out the SETQ-list
(COND ((MEMQ PROGN SETQLIST) (CLEARACS0 () )) ;but not vars that will go out
('T ((LAMBDA (CNT) (CLEARVARS)) (CADDR LLL)))) ;of date during LAMBDA
(SETQ LMRSL (SLOTLISTCOPY)) ;Remember how deep the slotlist is
(CNPUSH (CAR (CDDDDR LLL)) () ) ;Push NLNVTHTBP
(AND (CDR FORM) ;Compute up arglist, iloc items,
(PROG (SPLL1 SPLLV RGLLL RGLLM LMQL VMS N LARGSLOTP) ;Keep track of QUOTE stuff for
(SETQ VMS (MAPCAR 'VARMODE (CAR LLL))) ;efficient binding, and separate
(DO ((VAR (REVERSE (CAR LLL)) (CDR VAR)) ;out items for SPECIAL vars
(TYPEL (REVERSE VMS) (CDR TYPEL))
(ACLQ 'T) ;Hac to help find free acs
(AARGS (DO ((EFFS) (T1) (ARGNO 1) (AARGS) (TYPEL VMS (CDR TYPEL))
(Y (CDR FORM) (CDR Y)) (VAR (CAR LLL) (CDR VAR)))
((NULL Y) AARGS)
(COND ((NULL (CAR VAR)) (PUSH (COMPE (CAR Y)) AARGS))
((AND (NOT (SETQ SPFL (SPECIALP (CAR VAR))))
(CAR TYPEL))
(PUSH (COMPW (CAR Y) () #%(NUMVALAC)) AARGS)
(COMLOCMODE (CAR AARGS) 'FREENUMAC (CAR TYPEL) (CAR VAR)))
('T (SETQ TEM PNOB ;PNOB prohibited
PNOB (AND (NOT SPFL) (CAR VAR)) ; on special vars
T1 (COMP0 (CAR Y))
PNOB TEM)
(PUSH (OR (MAKESURE (CAR Y) (CAR VAR) SPFL T1 #%(ILOCN T1))
T1)
AARGS))))
(CDR AARGS)))
((NULL VAR))
(AND (NULL (CAR VAR)) (GO DOX))
(SETQ SPFL (SPECIALP (CAR VAR)))
(SETQ MODE (AND (NOT SPFL) (CAR TYPEL)))
(SETQ LARG (ILOCMODE (CAR AARGS) () MODE))
(REMOVE (CAR AARGS))
(SETQ LARGSLOTP (NUMBERP LARG))
(COND ((AND (NOT LARGSLOTP) (NULL (CDR LARG)))
(COND ((AND SPFL (NOT (QNILP (CAR LARG))) (NOT (ASSOC LARG LMQL)))
(COND ((NULL ACLQ) (SETQ N 0))
((NOT (ZEROP (SETQ N (FRACB)))))
((EQ ACLQ 'CLEARVARS) (SETQ ACLQ () ))
('T (CLEARVARS) (SETQ ACLQ 'CLEARVARS N (FRACB))))
(COND ((ZEROP N)
(OPUSH LARG (SETQ ITEM (CONS (CAR VAR) 'TAKEN)) MODE))
('T (PUSH (CONS LARG N) LMQL)
(OUT1 'MOVE N LARG)
(CONT N (CONS LARG 'TAKEN))
(SETQ ITEM (CONS (CAR VAR) LARG)))))
('T (SETQ ITEM (CONS (CAR VAR) LARG)))))
('T (COND ((COND (LARGSLOTP (COND ((AND (NOT MODE) (NOT (REGADP LARG)))
() )
('T (FIND LARG)
(AND (> LARG 0)
SPFL
(CPUSH1 LARG 'T () ))
(NOT (DVP1 SLOTX LARG)))))
((AND SPFL (NOT (ZEROP (SETQ N (LOADINREGAC
(CAR AARGS)
'FRACB
() )))))
(SETQ LARG N)
'T)
('T (AND (NOT (EQ (CAR LARG) 'SPECIAL))
(BARF LARG |Not LARGSLOTP - COMLAMAP|))
(OPUSH LARG () MODE)
(SETQ LARG (CONVNUMLOC 0 MODE))
'T))
(CONT LARG (SETQ ITEM (CONS (CAR VAR) 'TAKEN))))
('T (SETQ ITEM (CONS (CAR VAR) (CONS 'ILOC0 (CAR AARGS))))
(PUSH (CAR AARGS) LDLST)))))
(COND (SPFL (PUSH ITEM SPLL1) (PUSH (CAR VAR) SPLLV))
('T (PUSH MODE RGLLM) (PUSH ITEM RGLLL)))
DOX )
(SETQ SPFL (PROGHACSET SPLL1 (CADR LLL)))
; Cause the LAMBDA bindings to happen
(MAPC
'(LAMBDA (VAR MODE)
(COND ((EQ (CDR VAR) 'TAKEN) ;(VAR . TAKEN)
(RPLACD VAR () ))
((AND (NULL (CDDR VAR)) ;(VAR . ((QUOTE () )))
(OR (QNILP (CADR VAR)) ;(VAR . ((QUOTE 0)))
(AND MODE (Q0P+0P (CADR VAR)))))
(PUSH (CAR VAR) OLVRL))
('T
(SETQ TEM (COND ((EQ (CADR VAR) 'ILOC0) ;(VAR . (ILOC0 . QUANT))
#%(ILOCF (CDDR VAR)))
('T (CDR VAR)))) ;(VAR . ((QUOTE THING)))
(COND ((AND (NOT MODE) (NOT (REGADP TEM)))
(SETQ N (FRACB))
(COND ((ZEROP N) (CLEARVARS) (SETQ N (FRACB))))
(AND (ZEROP N) (BARF REGACS |COMLAMAP acs lossage|))
(AND (NOT (MEMQ (CAR VAR) UNSFLST))
(BARF (LIST (CAR VAR) TEM) |Unsafe var - COMLAMAP|))
(MAKEPDLNUM (CDDR VAR) N)
(CONT N (LIST (CAR VAR))))
('T (AND (EQ (CADR VAR) 'ILOC0) (REMOVEB (CDDR VAR)))
(OPUSH TEM (LIST (CAR VAR)) MODE))))))
RGLLL RGLLM)
;;; For binding to a special var, the item must be in an accumulator
;;; and a call to the pseudo function SPECBIND is made
(COND (SPLL1 (CPUSH (+ #%(NUMVALAC) 2)) ;SPECBIND uses acc R [= 11 = TT+2]
(OUTPUT '(JSP T SPECBIND))
(MAPC '(LAMBDA (VAR)
(MAP '(LAMBDA (SL) ;Kill REGAC slots
(AND (SETQ ITEM (CAR SL)) ; with specbound vars
(EQ (CAR ITEM) (CAR VAR))
(MEMQ (CDR ITEM) '(DUP () ))
(RPLACA SL () )))
REGACS)
(SETQ LARG
(COND ((EQ (CDR VAR) 'TAKEN)
(RPLACD VAR CNT)
(SETQ LARG (ILOC1 'T VAR () ))
(COND ((NOT (NUMBERP LARG))
(BARF () |Lost TAKEN - COMLAMAP|))
((PROG2 (SETQ N LARG) #%(PDLLOCP N))
(CONT LARG () )))
(RPLACD VAR 'DUP)
LARG)
((QNILP (CADR VAR)) () )
((EQ (CADR VAR) 'ILOC0)
(SETQ TEM (PROG2 ()
#%(ILOCF (SETQ TEM (CDDR VAR)))
(REMOVEB TEM)))
(COND (#%(PDLLOCP TEM)
(AND (NOT (DVP TEM)) (RPLACA SLOTX () ))
TEM)
('T (BARF TEM |Lost ILOC0 - COMLAMAP|))))
((SETQ LARG (ASSOC (CDR VAR) LMQL))
(CONT (CDR LARG) (LIST (CAR VAR)))
(CDR LARG))
('T (BARF () |Lost entirely - COMLAMAP|))))
(OSPB LARG (CAR VAR)))
SPLL1)
(DIDUP SPLLV)
(MAPC 'CARCDR-FREEZE SPLLV (CAR COMAL)) ;(CAR COMAL) has infinite list of ()s
(PUSH (CONS 'UNBIND (CADDR LLL)) GOBRKL)))))
; EXECUTE LAMBDA BODY AND RESTORE SLOTLIST
(SETQ BVARS (APPEND (CAR LLL) BVARS))
(SETQ ITEM ((LAMBDA (PNOB L-END-CNT) (COMP0 (CADR LLL)))
CONDPNOB (OR L-END-CNT (CADDR LLL)))
TEM () )
(COND ((AND (NOT EFFS)
(NOT (EQ (CAR ITEM) 'QUOTE))
(PROG2 (SETQ TEM (MEMQ (CAR ITEM) (CAR LLL)) Y #%(ILOCN ITEM))
(OR TEM (NOT #%(ACLOCP Y)))))
(SETQ LARG (COND (#%(NUMACP-N ARGNO) (LOADINNUMAC ITEM ARGNO Y 'REMOVEB))
((AND (OR TEM (NOT CONDPNOB))
(OR (NOT (REGADP Y)) (UNSAFEP ITEM)))
(LOADAC ITEM 1 'T)
1)
((LOADINREGAC ITEM ARGNO Y))))
(AND (OR TEM (NOT (EQUAL ITEM (CONTENTS LARG))))
(CONT LARG (SETQ ITEM (LIST (GENSYM)))))
(PUSH ITEM LDLST)))
(COND ((AND (L/.LE/. (CAR (SETQ TEM (CDDDR LMRSL))) REGPDL)
(L/.LE/. (CADR TEM) FXPDL)
(L/.LE/. (CADDR TEM) FLPDL))
(RESTORE LMRSL))
('T (DO Z '(REGACS () NUMACS () REGPDL 0 FXPDL #.(FXP0) FLPDL #.(FLP0))
(CDDR Z)
(NULL Z)
(DO ((SLOTL (SYMEVAL (CAR Z)) (CDR SLOTL)) (I 0 (1+ I)))
((NULL SLOTL))
(AND (CAR SLOTL)
(MEMQ (CAAR SLOTL) (CAR LLL))
(RPLACA SLOTL () ))))))
(SETQ CNT (1+ CNT))
(COND (SPFL (OUTPUT '(PUSHJ P UNBIND))))
(DIDUP SETQLIST)
(CLEANUPSPL () )
(REMOVE ITEM)
ITEM))
(DEFUN COMLOCMODE (ITEM FUN MODE VAR)
((LAMBDA (LARG NLARG OPPOSER)
(SETQ OPPOSER (COND ((NOT (NUMBERP LARG))
(COND ((EQ (CAR LARG) 'SPECIAL) (VARMODE (CADR LARG)))
((EQ (CAAR LARG) 'QUOTE)
(CAR (MEMQ (TYPEP (CADAR LARG)) '(FIXNUM FLONUM))))))
((PROG2 (SETQ NLARG LARG) #%(NUMACP-N NLARG))
(COND ((GETMODE0 LARG 'T () ))
('T (SETMODE LARG MODE) MODE)))
(#%(NUMPDLP-N NLARG)
(COND (#%(FLPDLP-N NLARG) 'FLONUM)
('FIXNUM)))
((GETMODE LARG))
('T MODE)))
(AND OPPOSER
(NOT (EQ MODE OPPOSER))
(DBARF (LIST (CONS VAR MODE) (CONS ITEM OPPOSER))
|Binding number variable to quantity of wrong type|))
0
LARG)
#%(ILOCNUM ITEM FUN)
0
()))
;;; dont try to substitute ILOC1 or ILOC2 for this ILOCNUM -
;;; You have to satisfy conflicts between the REGWORLD and NUMWORLD
(COMMENT COMLC for lsubr calls)
(DEFUN COMLC (X Y ITEMFL)
; Compile a CALL to an L-FORM - P1 places L-type CALLs within the scope of an
; internal LAMBDA application like ((LAMBDA () (LCALL * *)) () ).
; Thus a CLEAR is done by COMLAMAP
#%(LET ((OARGNO (COND ((AND (EQ (CAR X) COMP) (EQ (CADR X) 'FUNCALL)) 1)
((OR PNOB #%(NUMACP-N ARGNO)) ARGNO)
(1)))
(ARGNO 1) (OPNOB PNOB) (PNOB 'T) (NARGS (LENGTH Y)))
(PROG (TAG Z LZ RSL PDLTP)
(SETQ NARGS (LENGTH Y))
(COND ((NOT (ATOM X))
(AND (EQ (CAR X) COMP) #%(ILOCF (CADDR X))))
((ZEROP NARGS)
(CLEARACS1 X 'GENSYM) ;Remembering that COMLAMAP has CLEARVARS'd
(OUTPUT '(MOVEI T 0))
(SETQ ARGNO OARGNO PNOB OPNOB)
(RETURN (COML1 X 'CALL))))
(CLEARACS #.(+ (NACS) (NUMNACS)) () 'GENSYM) ;Remembering that COMLAMAP has CLEARVARS'd
(SETQ TAG (RETURNTAG))
(SETQ PDLTP (LIST (APPEND REGPDL '())))
(SETQ RSL (APPEND '(() () () ) PDLTP))
(MAPC
'(LAMBDA (ARG)
(SETQ LZ #%(ILOCREG (SETQ Z (COND (ITEMFL ARG)
('T (COMPW ARG () 1))))
1))
(RESTORE RSL)
(COND ((NOT (REGADP LZ)) (MAKEPDLNUM Z (SETQ LZ (FRACB))))
((REMOVEB Z)))
(COND ((AND #%(ACLOCP LZ)
(NOT ATPL)
(EQ (CAR LOUT) 'SUB)
(EQ (CADR LOUT) 'P)
(EQUAL LOUT '(SUB P (% 0 0 1 1))))
(SETQ LOUT (SETQ ATPL 'FOO))
(OUT1 'MOVEM LZ 0)
(PUSH '(NIL . TAKEN) REGPDL))
('T (AND #%(PDLLOCP LZ) (SETQ LZ (ILOC0 Z () )))
(OPUSH LZ '(NIL . TAKEN) () )))
(RPLACA PDLTP (CONS '(NIL . TAKEN) (CAR PDLTP))))
Y)
(AND (CLEARACS0 () ) ;Check for importent things
(BARF () |Too much value - COMLC|)) ; being inadvertently left in ACs
(CLEARACS1 X () ) ;Clobber out the ACs to be used
#%(OUTFS 'MOVNI 'T NARGS)
(SETQ ARGNO OARGNO PNOB OPNOB)
(SETQ Z (COML1 X 'JCALL))
(OUTPUT TAG)
(SHRINKPDL (1+ NARGS) () )
(RETURN Z))))
(DEFUN COML1 (X OP)
(COND ((EQ (CAR X) COMP)
((LAMBDA (LOC INST)
(REMOVEB (CADDR X))
(COND (INST (SETQ INST (COND ((EQ OP 'CALL) (CAR INST))
((CADR INST))))
(OUT1 (CAR INST) (CADR INST) LOC)
1)
('T (OUT1 'MOVE #%(NUMVALAC) LOC)
(OUTPUT (COND ((EQ OP 'CALL) '(PUSHJ P @ 1 #.(NUMVALAC)))
('T '(JRST 0 @ 1 #.(NUMVALAC)))))
(RPLACA ACSMODE (CADR X))
#%(NUMVALAC))))
#%(ILOCF (CADDR X))
(COND ((EQ (CADR X) 'FUNCALL) '(((CALLF) 16) ((JCALLF) 16)))
((NULL (CADR X)) '(((PUSHJ) P) ((JRST) 0))))))
((OUTFUNCALL OP 16 X))))
(DEFUN COMMAKNUM (Y)
#%(LET ((VALAC 1) Z TEM)
#%(LET ((ARGNO (COND (#%(NUMACP-N ARGNO)
(COND ((NOT (DVP ARGNO)) (SETQ TEM ARGNO))
((NOT (ZEROP (SETQ TEM (FREENUMAC1)))))
((SETQ TEM #%(NUMVALAC))))
(FRAC5))
('T ;(SETQ UNSAFEP PNOB)
(SETQ TEM () ) 1)))
EFFS PNOB)
(SETQ Z (COMP0 (CAR Y)) Y ARGNO))
(CPUSH (SETQ VALAC (OR TEM #%(NUMVALAC))))
(SETQ Y #%(ILOCREG Z Y))
(REMOVEB Z)
(AND #%(ACLOCP Y) (CPUSH Y))
(CCSWITCH VALAC Y)
(SETMODE VALAC 'FIXNUM)
(COND ((NULL TEM)
(CPUSH 1)
(COND ((NOT PNOB)
(SETQ VALAC 1)
(OUTPUT '(JSP T FXCONS))
#%(NULLIFY-NUMAC)))))
VALAC))
(DEFUN COMMUNKAM (Y)
#%(LET* ((Z (COMP0 (CAR Y)))
(TEM #%(ILOCN Z))
(VALAC (COND ((AND #%(ACLOCP TEM)
(NOT #%(NUMACP TEM)))
TEM)
(#%(NOT (NUMACP-N ARGNO)) ARGNO)
((FRAC5)))))
(REMOVEB Z)
(COND (#%(NUMACP TEM) #%(LET ((TAKENAC1 TEM)) (CPUSH VALAC)))
((CPUSH VALAC)))
(OUT1 (COND ((REGADP TEM) '(HRRZ)) ('HRRZ)) VALAC TEM)
VALAC))
(DEFUN COMNULL (Y)
((LAMBDA (LY TEM FL N)
(COND ((NOT EFFS)
(COND ((CCHAK-BOOL1ABLE Y () ))
('T (SETQ TEM (COMP0 Y) LY #%(ILOCREG TEM ARGNO)
FL (NUMBERP LY))
(AND FL (SETQ N LY))
(REMOVEB TEM)
(FIND ARGNO)
(AND (CPUSH1 ARGNO () LY)
FL
#%(REGPDLP-N N)
(SETQ FL (NUMBERP (SETQ LY (ILOC0 TEM () ))))
(SETQ N LY))
(COND ((AND FL #%(ACLOCP-N N)) (OUTPUT (BOLA N 3)))
('T (OUT1 'SKIPE 0 LY)))))
(BOOLOUT () () ))
((COMPE Y))))
() () () 0))
(DEFUN COMPLIST (Y)
#%(LET ((VALAC 1) Z T1 TEM)
(SETQ T1 #%(ILOCN (SETQ Z (COMP0 (CAR Y))))
TEM (COND ((NOT (NUMBERP T1)) () )
((> T1 0) 'PLUSP)
('T)))
(REMOVEB Z)
(SETQ VALAC (COND ((EQ TEM 'PLUSP) (CPUSH T1) T1)
((NOT (DVP ARGNO)) ARGNO)
(#%(FREAC))))
(COND ((AND (NULL TEM)
(NULL (CDR T1))
(EQ (CAAR T1) 'QUOTE))
#%(OUTFS 'HRRZ
VALAC
(COND ((CADAR T1) (CAR T1))
('T 'NILPROPS))))
('T (COND ((EQ TEM 'PLUSP)
#%(OUTFS 'SKIPN (COND ((= T1 VALAC) 0) (T1)) T1))
((OUT1 'SKIPN VALAC T1)))
#%(OUTFS 'SKIPA VALAC 'NILPROPS)
#%(OUTFS 'HRRZ VALAC 0 VALAC)
#%(|Oh, FOO!|)))
VALAC))
(COMMENT COMPROG COMPROGN AND COMRETURN)
(DEFUN COMPROG (Y)
;;; Y = (complexity setqlist golist <specvars modelist ignorevars> progvars progbody progunsf nlnvthtbp)
(AND (NULL SFLG) (CLEAR (CADR Y) 'T))
#%(LET ((OARGNO ARGNO)
(PVR ARGNO)
(OPVRL (COND (PVRL (CONS PVRL OPVRL)) (OPVRL)))
(SPFL SFLG)
(OEFFS EFFS)
(ARGNO 1)
(EFFS 'T)
(EXLDL LDLST)
(PROGP LDLST))
(OR (AND (NOT EFFS) (NOT (= ARGNO 1)) (< (CAR Y) 2))
#%(NUMACP-N ARGNO)
(SETQ PVR 1))
(PROG (EXIT EXITN LPRSL PRSSL GOBRKL VGO GL PVRL SPECVARS MODELIST
IGNOREVARS PNOB RETURNP TEM LY L-END-CNT PROGTYPE)
(SETQ MODELIST (CAR (SETQ LY (CDDDR Y))))
#%(DESETQ (SPECVARS MODELIST IGNOREVARS) MODELIST)
(MAPC '(LAMBDA (X)
(AND (SPECIALP X)
(PROG2 (COND ((NULL SPFL)
(SETQ SPFL 'T)
(CPUSH #.(+ (NUMVALAC) 2))
(OUTPUT '(JSP T SPECBIND))))
(OSPB () X))))
(CADR LY))
(COND (SFLG (CLEAR (CADR Y) 'T) (SETQ SFLG () )))
(SETQ CNT (ADD1 CNT))
(SETQ GL (CADDR Y))
(SETQ PVRL (MAPCAN '(LAMBDA (X) (AND (NOT (SPECIALP X)) (LIST X)))
(CAR (SETQ LY (CDR LY)))))
(CNPUSH (CADDR (SETQ LY (CDR LY))) () ) ;PUSH NLNVTHTBP
(MAP '(LAMBDA (X)
(SETQ CNT (ADD1 CNT))
(COND ((ATOM (CAR X))
(COND ((SETQ TEM (ADR (CAR X)))
#%(CLEARALLACS)
(CPVRL)
(RESTORE PRSSL)
(COND ((NOT ATPL) (PUTPROP TEM LOUT 'PREVI)))
(OUTTAG0 TEM)
(CLEANUPSPL () )))
(SETQ RETURNP () ))
((AND (NULL (CDR X)) (EQ (CAAR X) 'RETURN))
(COMRETURN (CDAR X) () )
(SETQ RETURNP 'T))
('T (COND ((EQ (CAAR X) 'COND)
(AND (MEMQ GOFOO (CADDAR X)) (RESTORE PRSSL))
(COMCOND (CDAR X)
()
()
(AND (CDR X)
(EQ (CAADR X) 'GO)
(ATOM (SETQ TEM (CADADR X)))
(ADR TEM))))
('T (COMPW (CAR X) 'T 1))))))
(CAR LY))
(COND ((AND (NULL LPRSL)
(COND ((NULL EXIT)
(AND (NOT OEFFS) (CMPRGLDNIL 'T))
'T)
((NULL EXITN))))
(CLEANUPSPL () )
(SETQ CNT (+ CNT 2))
#%(CLEARALLACS))
('T (SETQ RETURNP (AND (NOT RETURNP)
(OR ATPL (NOT (EQ (CAR LOUT) 'JRST)))))
(OUTTAG EXITN)
(AND (NOT OEFFS) (CMPRGLDNIL RETURNP))
(OUTTAG EXIT)
#%(CLEARALLACS)
(OR EXIT EXITN (CLEANUPSPL () ))
(SETQ CNT (+ CNT 2))))
(COND (SPFL (CPUSH #.(+ (NUMVALAC) 2)) (OUTPUT '(PUSHJ P UNBIND))))
(DIDUP (CADR Y))
(AND VGO (PUSH (CONS VGO (GCDR 'CAAR GL)) VGOL))
(AND #%(NUMACP-N PVR)
(SETMODE PVR (COND (PROGTYPE) ('FIXNUM))))
(RETURN PVR))))
(DEFUN COMPROGN (L OEFFS)
(IF L
(LET ((EFFS 'T)
(ARGNO ARGNO)
(OARGNO ARGNO))
;;First, compute for effects all but last item
(DO ((NL))
((NULL (SETQ NL (CDR L))))
(COMP0 (CAR L))
(SETQ L NL))
;;Then restore the original EFFS and ARGNO, and do last one
(SETQ EFFS OEFFS ARGNO OARGNO)
(COMP0 (CAR L)))))
(DEFUN CMPRGLDNIL (FL)
(AND (OR FL EXITN)
(COND (#%(NUMACP-N PVR) (LOADAC '(QUOTE 0) PVR () ))
((NOT (QNILP (CONTENTS PVR))) (LOADAC '(QUOTE () ) PVR 'T)))))
(DEFUN COMRETURN (Y GOP)
((LAMBDA (ARGNO)
(COND ((QNILP (CAR Y))
(GENTAG 'EXITN)
(AND GOP (COMGORET EXITN 0)))
('T ((LAMBDA (PNOB ARGNO EFFS)
(LOADAC (COMP0 (CAR Y)) PVR 'T))
() PVR ())
(AND #%(NUMACP-N PVR)
(SETQ Y (CAR #%(ACSMODESLOT PVR)))
(COND ((NULL PROGTYPE) (SETQ PROGTYPE Y))
((NOT (EQ PROGTYPE Y)) (SETQ PROGTYPE 'FIXNUM))))
(GENTAG 'EXIT)
(AND (OR GOP EXITN) (COMGORET EXIT PVR)))))
PVR))
(COMMENT COMREMAINDER AND COMSHIFTS)
(DEFUN COMREMAINDER (ARGL)
(DO ((ARGNO #%(NUMVALAC)) (TAKENAC1 TAKENAC1) (EFFS) (ARG1) (ARG2) (AC) (LARG) (SVSLT))
()
(SETQ ARG1 (COMP0 (CAR ARGL)))
(AND (NOT (EQ (CAR ARG1) 'QUOTE)) ;If 2nd arg computation is
(NOT (ATOM (CADR ARGL))) ; complicated, and 1st is
(NOT (EQ (CAR (CADR ARGL)) 'QUOTE)) ; in NUMAC, but dunno type,
(SETQ LARG (ILOC0 ARG1 'FIXNUM)) ; then force to be FIXNUM
#%(NUMACP LARG)
(NULL (CAR (SETQ LARG #%(ACSMODESLOT LARG))))
(RPLACA LARG 'FIXNUM))
(SETQ ARGNO #%(NUMVALAC)
ARG2 (COMP0 (CADR ARGL))
TAKENAC1 (1- (+ #%(NUMVALAC) #%(NUMNACS)))
AC (FREENUMAC)
LARG #%(ILOCNUM ARG1 #%(NUMVALAC)))
(COND ((AND #%(NUMACP LARG)
(< LARG #.(1- (+ (NUMVALAC) (NUMNACS)))))
(REMOVEB ARG1)
(SETQ AC LARG))
((LOADINNUMAC ARG1 AC () 'REMOVEB)))
(FIND AC)
(CPUSH1 AC () () )
(RPLACA SLOTX '(NIL . TAKEN))
(SETQ SLOTX (CDR (SETQ SVSLT SLOTX))) ;SETUP FOR ENTRY TO CPUSH1
(CPUSH1 (1+ AC) () () )
(SETQ LARG #%(ILOCNUM ARG2 (1+ AC)))
(REMOVEB ARG2)
(OUT3 '(IDIV) AC LARG)
(SETQ LARG #%(ACSMODESLOT AC))
(AND (NULL (CDR LARG)) (BARF AC |WHATS THIS AC DOING HERE -COMREMAINDER|))
(RPLACA LARG () ) ;SETMODE AC NIL
(RPLACA (CDR LARG) 'FIXNUM) ;SETMODE AC+1 'FIXNUM
(RPLACA SVSLT () ) ;CONT AC ()
(RETURN (CAR (RPLACA (CDR SVSLT) (LIST (GENSYM)))))))
(DEFUN COMSHIFTS (OP AARGS)
#%(LET ((ARGNO #%(NUMVALAC))
(TAKENAC1 0)
EFFS ARG1 ARG2 )
(SETQ ARG1 (COMP0 (CAR AARGS)) ARG2 (COMP0 (CADR AARGS)))
(SETQ TAKENAC1 (LOADINSOMENUMAC ARG1))
(SETQ ARG1 (COND ((EQ (CAR ARG2) 'QUOTE) (REMOVE ARG2) (CADR ARG2))))
(COND ((COND ((NULL ARG1) () )
((EQ OP 'FSC) (> ARG1 262143.)) ;FSC N,HUGE leaves unnormalized
((= ARG1 0)))) ;LSH.ASH.ROT N,0 does nothing
('T (SETQ ARG2 (COND (ARG1 (LIST ARG1))
((LIST 0 (LOADINSOMENUMAC ARG2)))))
(AND (NOT ARG1)
(EQ OP 'FSC)
#%(OUTFS 'CAIG (CADR ARG2) 262143.))
(OUTPUT (CONS OP (CONS TAKENAC1 ARG2)))))
(SETMODE TAKENAC1 (COND ((EQ OP 'FSC) 'FLONUM) ('FIXNUM)))
(CAR (CONT TAKENAC1 (LIST (GENSYM))))))
(COMMENT COMRPLAC)
(DEFUN COMRPLAC (FUN L VAL)
(PROG (X Y LX LY OCNT)
(CSLD () 'T () ) ;Grabs in only CARCDR loadings
(SETQ OCNT CNT)
((LAMBDA (PNOB EFFS ARGNO)
(SETQ X (COMP0 (CAR L))
Y (COMP0 (CADR L)))
(SETQ Y (MAKESAFE Y #%(ILOCREG Y 1) () )))
() () 1)
(SETQ LX #%(ILOCN X) LY (ILOC0 Y () ))
(AND (NOT (REGADP LX)) (PDERR (CONS FUN L) |Cant RPLAC numeric data|))
(AND #%(PDLLOCP LX)
(EQ (CDR (CONTENTS LX)) 'IDUP)
(PROG2 ((LAMBDA (CNT) (DIDUP (LIST (CAR X)))) OCNT)
(SETQ LX (ILOC0 X () ))))
(COND ((AND (EQ FUN 'SETPLIST) ;Skip case of
(OR (NOT (EQ (CAR X) 'QUOTE)) (NULL (CADR X)))) ; (SETPLIST x '())
(REMOVEB X)
(SETQ OCNT (COND (#%(ACLOCP LX) (CPUSH LX) LX)
((OR EFFS (DVP ARGNO)) #%(FREAC))
('T ARGNO)))
(OUT1 'SKIPN OCNT LX)
#%(OUTFS 'MOVEI OCNT 'NILPROPS)
(PUSH (SETQ X (LIST (GENSYM))) LDLST)
(CONT (SETQ LX OCNT) X)))
(COND ((QNILP Y) (OUT1 (GET FUN 'INSTN) 0 LX))
('T (SETQ LY #%(ILOCREG Y (COND ((AND (NULL EFFS) ;This is just ILOCF
(AND (NUMBERP LX) (= LX 1))
(= ARGNO 1) ; except when result
(NULL VAL)) ; is to go into 1
#%(FREAC))
('FRAC1))))
(AND (NOT #%(ACLOCP LY)) (LOADAC Y (SETQ LY (FRAC1)) 'T))
(OUT1 (GET FUN 'INST) LY (ILOC0 X () ))))
;;SO FORGET ABOUT ANY NASCENT CARCDRINGS
(OR VAL (PSETQ X Y Y X))
;; common case is VAL = (), so just return 2nd arg to RPLACA
(REMOVE X)
(CLEANUPSPL 'COMRPLAC)
(REMOVE Y)
(RETURN Y)))
(DEFUN COMSET (Y)
#%(LET (NAME V (ARGNO 1) EFFS)
(CSLD 'T () () )
(SETQ NAME (COMP0 (CAR Y)))
(SETQ V (COMP0 (CADR Y)))
(LOADAC NAME 4 () )
(AND (SETQ NAME (GETMODE0 4 () () ))
(PDERR (CONS 'SET Y) |SET applied to numeric datum|))
(LOADAC V 1 'T)
(CPUSH #%(NUMVALAC))
(OUTPUT '(JSP T *SET))
#%(NULLIFY-NUMAC)))
(COMMENT COMSETQ)
(DEFUN COMSETQ (Y)
(PROG (LARG HOME V Z TEM NLP MODE LARGSLOTP DOD CMPVL SPFL NLARG)
COMSQ1
(SETQ MODE (AND (NOT (SETQ SPFL (SPECIALP (CAR Y)))) (VARMODE (CAR Y))))
(SETQ NLP (CDDR Y))
(SETQ HOME (ILOC0 (SETQ V (CONS (CAR Y) CNT)) MODE) TEM () )
(COND ((AND MODE
HOME
(SETQ TEM (NOT (ATOM (CADR Y))))
(SETQ Z (COND ((EQ (CAADR Y) 'ADD1) 'AOS)
((EQ (CAADR Y) 'SUB1) 'SOS)))
(AND (CDDR (CADR Y)) (NULL (CDDDR (CADR Y)))) ;LENGTH = 3
(EQ (CAR V) (CAR (CDDADR Y)))
(EQ (CADADR Y) 'FIXNUM)
(OR (NOT (ASSQ (CAR V) LDLST)) (NOT (DVP HOME)))
(NOT (REGADP HOME)))
(COND ((AND #%(ACLOCP HOME) (CDR (CONTENTS HOME)))
(CPUSH1 HOME 'T () ) ;SLOTX has still been setup by CONTENTS
(RPLACA SLOTX () ) ; hence this becomes (CONT HOME () )
(SETQ HOME (ILOC2 'T V 'FIXNUM))))
(FREEZE-VAR (CAR V) '(REGACS () REGPDL 0) () 'T MODE) ;Remember, increments CNT
(ASIDE-FROM-FOO Z NLP HOME (CAR V) MODE) ;Z has INST, (CAR V) the var's name
(SETQ CNT (PLUS CNT 2))
(GO COMPS3)))
(COND ((AND TEM ;Prev value is
(SETQ TEM (CAADR Y)) ;(AND MODE HOME (NOT (ATOM (CADR Y))))
(MEMQ TEM '(PLUS TIMES DIFFERENCE *DIF))
(CDDDR (CADR Y)) ;Typical Y = (N (PLUS FIXNUM N FOO))
(NULL (CDDDDR (CADR Y))) ; Check length[cadr[y]] = 4
(CAR (SETQ Z (CDADR Y))) ;Z = (FIXNUM N FOO)
(ATOM (CAR Z))
(EQ (CAR Y) (CADR Z))
(SETQ Z (CADDR Z))
(COND ((NOT #%(ACLOCP HOME)))
((EQ (CDR (CONTENTS HOME)) 'DUP)
(RPLACA SLOTX () ))
((ATOM Z) () )
((NOT (EQ (CAR Z) CARCDR)))))
(COND ((MEMQ TEM '(*DIF DIFFERENCE))
(SETQ TEM 'PLUS)
(SETQ Z (LIST 'MINUS (CADADR Y) Z))))
(SETQ Y (LIST (CAR Y) (LIST TEM (CADADR Y) Z (CAR Y))))))
(SETQ CMPVL (COMPR (CADR Y)
MODE
EFFS
(AND (NOT SPFL) (OR MODE (MEMQ (CAR Y) UNSFLST)))))
(SETQ LARG (COND (MODE (COMLOCMODE CMPVL 'ARGNO MODE (CAR Y)))
('T #%(ILOCREG CMPVL (COND (NLP 'FRACF) ('ARGNO))))))
(AND (OR SPFL (NOT MODE))
(SETQ TEM (MAKESURE (CADR Y) (CAR Y) SPFL CMPVL LARG))
(SETQ CMPVL TEM
LARG (COND ((EQ (CAR REGACS) CMPVL) 1)
((ILOC0 CMPVL () ))
((BARF CMPVL |Lost at makesure - COMSETQ|)))))
(AND (SETQ LARGSLOTP (NUMBERP LARG)) (SETQ NLARG LARG))
(COND ((AND SPFL
(SETQ TEM (ASSQ (CAR Y) LDLST))
(NOT (NUMBERP (ILOC0 TEM () ))))
#%(OUTFS 'PUSH 'P (LIST 'SPECIAL (CAR Y)))
(PUSH (CONS (CAR Y) CNT) REGPDL)
(SETQ SPLDLST (DELQ TEM SPLDLST))
(AND LARGSLOTP
#%(REGPDLP-N NLARG)
(SETQ NLARG (SETQ LARG (1- NLARG))))))
(REMOVEB CMPVL)
(COND ((AND MODE ;MODE=T => SPFL=()
LARGSLOTP
(NOT ATPL)
(AND (CDDDR LOUT) (NULL (CDDDDR LOUT))) ;LENGTH = 4
(SETQ TEM (GET (CAR LOUT) 'BOTH))
(NUMBERP (CADDR LOUT))
(= LARG (CADR LOUT))
(EQ (CADDDR LOUT) #%(PDLAC MODE))
(EQUAL (SETQ Z (ILOC0 V MODE))
(CONVNUMLOC (CADDR LOUT) MODE))
(NOT (DVP (CADR LOUT)))
(OR (NOT (ASSQ (CAR Y) LDLST)) (NOT (DVP Z))))
(CONT (CADR LOUT) (CONS (CAR Y) 'DUP))
(RPLACA LOUT TEM)
(FREEZE-VAR (CAR V) '(REGACS () REGPDL 0) () 'T MODE)
(SETQ CNT (1+ CNT))
(GO COMPS3)))
(SETQ V (CAR Y))
; So freeze world at this point
(SETQ TEM (FREEZE-VAR V
'(REGACS () NUMACS () REGPDL 0 FXPDL #.(FXP0) FLPDL #.(FLP0))
(CAR CMPVL)
()
MODE))
(AND LARGSLOTP #%(PDLLOCP-N NLARG)
(SETQ LARGSLOTP (NUMBERP (SETQ LARG (ILOC2 (VARBP (CAR CMPVL))
CMPVL
(GETMODE LARG)))))
(SETQ NLARG LARG))
(SETQ DOD (AND LARGSLOTP (DVP LARG)))
(SETQ HOME
(COND (SPFL) ;HOME = () =>
((NULL TEM) () ) ;Local var without home on PDL
((NOT (DVP4 (CAAR TEM) (CDR TEM))) ; or else locvar with DVP home
(CDR TEM)))) ;HOME = non-null =>
; can store into old homeloc
(SETQ CNT (1+ CNT))
(COND ((AND (OR EFFS NLP) (NOT HOME) (OR MODE (REGADP LARG)))
(SETQ V (LIST V))
(COND ((AND LARGSLOTP (NOT DOD))
(COND ((AND MODE #%(REGADP-N NLARG)) (OPUSH LARG V MODE))
('T (CONT LARG V))))
('T (OPUSH LARG V MODE)))
(GO COMPS3)))
(COND ((AND HOME
(COND (MODE (Q0P+0P (CADR Y)))
('T (QNILP (CADR Y)))))
(ASIDE-FROM-FOO 'SETZM NLP HOME V MODE)
(GO COMPS3)))
(COND ((COND ((NOT DOD) () )
((NOT (NUMBERP LARG)) () )
(MODE #%(NUMACP-N NLARG))
('T #%(REGACP-N NLARG)))
(CPUSH LARG))
((AND (NULL MODE) LARGSLOTP #%(NUMACP-N NLARG))
(AND DOD (CPUSH LARG))
(PUSH (SETQ CMPVL (CONS (CAR CMPVL) CNT)) LDLST)
(SETQ LARG (COND ((AND (NOT EFFS) (NULL NLP) (NOT #%(NUMACP-N ARGNO)))
ARGNO)
((FRAC1))))
(MAKEPDLNUM CMPVL LARG))
((OR (NOT LARGSLOTP)
DOD
(MINUSP LARG)
(DVP LARG)
(AND MODE (REGADP LARG)))
(LOADAC CMPVL (SETQ LARG (COND ((AND (NOT EFFS) (NULL NLP))
(COND ((NOT #%(NUMACP-N ARGNO))
(COND (MODE #%(NUMVALAC)) (ARGNO)))
(MODE ARGNO)
((FRAC5))))
(MODE (FREENUMAC))
((FRAC5))))
())))
(CONT LARG (LIST V))
(COND (SPFL
(COND ((REGADP LARG)
(COND ((ZEROP LARG) (OPOP SPFL () ))
('T #%(OUTFS 'MOVEM LARG SPFL))))
('T (BARF (LIST V LARG) |Special set from ? - COMSETQ|)))))
COMPS3
(COND (NLP (SETQ Y NLP) (GO COMSQ1))
((NULL EFFS)
(SETQ V (CONS (CAR Y) CNT))
(AND SPFL (SETQ SPLDLST (CONS V SPLDLST)))
(RETURN V)))))
;;; Puts out things like (SETZ 0 (SPECIAL FOO)) (SETZB 7 -3 FXP)
;;; (AOS 0 11) (SOS 7 0 FXP)
(DEFUN ASIDE-FROM-FOO (INST NLP HOME V MODE) ;CALLED ONLY FROM COMSETQ
((LAMBDA (AC)
(OUT1 (COND ((OR NLP EFFS) INST)
('T (SETQ AC (COND (MODE (FREENUMAC))
((NOT (DVP ARGNO)) ARGNO)
((NOT (ZEROP (SETQ AC (FRACB)))) AC)
('T (CPUSH ARGNO) ARGNO)))
(COND ((EQ INST 'SETZM) 'SETZB) (INST))))
AC
(COND ((NUMBERP HOME) (CONT HOME (LIST V)) HOME)
(HOME))) ;Should be (SPECIAL foo)
(AND (NOT (ZEROP AC)) (CONT AC (CONS V (COND ((NUMBERP HOME) 'DUP)))))
() )
0))
(DEFUN FREEZE-VAR (V L ITEM OEFFS MODE)
((LAMBDA (OHOME HOME II N)
(SETQ V (CONS V (SETQ CNT (1+ CNT))))
(DO ZZ L (CDDR ZZ) (NULL ZZ)
(DO ((Z (SYMEVAL (CAR ZZ)) (CDR Z)) (I 0 (1+ I)) (PDLP (CADR ZZ)))
((NULL Z))
(AND (CAR Z)
(EQ (CAAR Z) (CAR V))
(COND ((MEMQ (CDAR Z) '(() OHOME))
(COND ((NULL PDLP) (RPLACA Z V))
((AND (NULL (CDAR Z)) (NULL HOME))
(SETQ HOME Z II (- PDLP I)))
((AND (EQ (CDAR Z) 'OHOME) (NULL OHOME))
(SETQ OHOME Z N (- PDLP I)))
((BARF () |King of confusion - FREEZE-VAR|))))
((MEMQ (CDAR Z) '(DUP IDUP)) (RPLACD (CAR Z) (1- CNT)))))))
(AND HOME (RPLACA HOME V))
(COND (OHOME
(COND ((DVP4 (CAR OHOME) N)
(OPUSH N
(CONS (CAR V) (GET (CAR V) 'OHOME))
MODE)
(AND HOME
(NOT OEFFS)
(EQ (GETMODE N) (GETMODE II))
(SETQ II (1- II)))))
(PUTPROP (CAR V) CNT 'OHOME))
(HOME
(COND ((DVP4 (CAR HOME) II)
(OPUSH II V MODE)
(SETQ II (1- II))))
(PUTPROP (CAR V) CNT 'OHOME)
(RPLACA HOME (CONS (CAR V) 'OHOME))))
(CARCDR-FREEZE (CAR V) ITEM)
(AND (NOT OEFFS) HOME (CONS HOME II)))
() () 0 0))
(COMMENT COMTP for "TYPEP")
(DEFUN COMTP (EXP INST TAG F VALUEP) ;Compile for "TYPEP"
#%(LET ((ARGNO (COND (VALUEP ARGNO) ((FRAC1)))))
(PROG (TEM LOC AC ACP) ; and similar functions
(SETQ AC 0) ;Table index for that type datum
(SETQ LOC #%(ILOCN (SETQ TEM (COMP (CADR EXP))))) ; into some free NUMAC, which is returned
(REMOVE TEM) ; [except for case of "ATOM"]
(AND VALUEP ;If no TAG, then for value
(CPUSH-DDLPDLP ARGNO LOC)
(SETQ LOC (1- LOC)))
(COND ((COND ((NUMBERP LOC) (SETQ TEM (GETMODE LOC))) ;If quantity is known to be
((AND (NULL (CDR LOC))
(MEMQ (SETQ TEM (TYPEP (CADAR LOC)))
'(FIXNUM FLONUM)))))
(SETQ LOC (COND ((EQ (CAR EXP) 'TYPEP) TEM) ; either FIXNUM or FLONUM
((MEMQ (CAR EXP) '(ATOM NUMBERP)) 'T) ; then return that instead
((EQ (CAR EXP) 'BIGP) () ) ; of compiling code for getting
((MEMQ (CAR EXP) '(FIXP FLOATP FIXNUMP)) ;the type bits into a NUMAC
#%(EQUIV (EQ (CAR EXP) 'FLOATP)
(EQ TEM 'FLONUM)))))
(SETQ TEM #%(EQUIV LOC F)) ;Match the type of cadr[exp]
(COND (TAG (AND TEM (PROG2 (CLEARVARS) (OJRST TAG 0)))) ;predicates - but not "TYPEP"
((OUTPUT (COND ((NULL INST) (LIST 'MOVEI ARGNO (LIST 'QUOTE LOC)))
(#%(EQUIV LOC F) (BOLA ARGNO 2))
('T (BOLA ARGNO 5) )))))
(RETURN 'T)))
(COND (#%(ACLOCP LOC)
(CPUSH LOC)
(CONT LOC () )
(SETQ AC LOC ACP 'T)))
(COND ((EQ (CAR EXP) 'TYPEP)
(AND (OR EFFS #%(NUMACP-N ARGNO)) (BARF () |Sumpins wrong - COMTP|))
(OUT1 'SKIPN
(COND ((NULL ACP) (SETQ AC ARGNO) ARGNO)
(0))
LOC)
(OUTPUT (BOLA AC 2)) ;MOVEI ARGNO,'T
#%(OUTFS 'LSH AC -9.) ; ### since ()=NIL is SYMBOL
(CONT AC () )
(OUTPUT (CONS 'HRRZ (CONS ARGNO (CDR (STGET AC)))))
(RETURN () )))
(COND ((NULL ACP) (SETQ AC (FREENUMAC)) (OUT1 'MOVE AC LOC)))
(COND (TAG (CLEARVARS) (RSTD TAG AC 0)))
(COND ((EQ (CAR EXP) 'ATOM)
#%(OUTFS 'LSH AC -9.)
(CONT AC () )
(SETQ INST (COND (#%(EQUIV F TAG) 'SKIPL) ('SKIPGE)))
(OUTPUT (CONS INST (STGET AC)))
(COND (TAG (OUTJ0 'JUMPA 0 TAG 'T 0)) ;Like OJRST, but no
(VALUEP (BOOLOUT () () )))) ; subsequent deletions
('T (PROG (VTAG)
(COND ((NOT (EQ (CAR EXP) 'SYMBOLP)))
((AND TAG F) (OUTJ 'JUMPE AC TAG))
((AND F (NULL TAG) (NULL VALUEP))
(OUTPUT (BOLA AC 6)) ;SKIPN 0 ac
(OUTPUT (BOLA AC 2))) ;MOVEI ac,'T
('T #%(OUTFS 'JUMPE AC (SETQ VTAG (GENSYM))) ))
#%(OUTFS 'LSH AC -9.)
(CONT AC () )
(SETQ TEM (CDR (STGET AC)))
(COND ((NOT #%(NUMACP-N AC))
(SETQ AC (FREENUMAC))
(RPLACA SLOTX () ))) ;(CONT AC () )
(OUTPUT (CONS 'MOVE (CONS AC TEM)))
(SETQ INST (COND (F (CAR INST)) ((CDR INST))))
(COND (TAG (OUTJ INST AC TAG)
(AND VTAG (OUTPUT VTAG)))
('T #%(OUTFS (CAR INST) AC (CDR INST))
(AND VTAG (NULL F) (OUTPUT VTAG))
(AND VALUEP (BOOLOUT (AND F VTAG) () ))))))) )))
(COMMENT COMSIGNP and COMZP)
;;; This compilation critically depends on the subr for NUMBERP leaving a
;;; numerical value in accumulatr TT with the correct algebraic sign.
(DEFUN COMSIGNP (EXP TAG F)
((LAMBDA (INST)
(AND (NULL INST)
(SETQ INST '(- . JUMP))
(PDERR (CAR EXP) |Wrong type arg to SIGNP|))
(LOADAC (COMP1 (CADR EXP)) 1 () )
(CPUSH #%(NUMVALAC))
#%(NULLIFY-NUMAC)
(OUTPUT '(CALL 1 'NUMBERP))
(COND ((COND ((NULL TAG))
(F (CLEARVARS) (RSTD TAG 1 0) 'T))
(OUTPUT '(SKIPE 0 1)))
('T (CLEARVARS) (OUTJ0 'JUMPE 1 TAG () 1)))
(SETQ INST (COND ((OR F (NULL TAG)) (CDR INST))
((GET (CDR INST) 'CONV))))
(RPLACA REGACS () ) ;(CONT 1 () )
(COND (TAG (OUTJ0 INST 'TT TAG 'T 0))
('T #%(OUTFS INST 'TT '(* 2))
(OUTPUT '(MOVEI 1 '() )))))
(ASSQ (CAR EXP)
'((L . JUMPL) (E . JUMPE) (LE . JUMPLE)
(GE . JUMPGE) (N . JUMPN) (G . JUMPG)))))
(DEFUN COMZP (EXP TAG F)
((LAMBDA (Z INST NODDP)
(SETQ INST (COND (TAG (CAR INST)) ((CDR INST))))
(AND (NOT F) (SETQ INST (GET INST 'CONV)))
(COND (TAG (OUTJ (COND (NODDP INST)
;((ASSQ INST '((TRNN . 1) (TRNE . 1))))
((EQ INST 'TRNN) '(TRNN . 1))
((EQ INST 'TRNE) '(TRNE . 1)))
(LOADINSOMENUMAC Z)
TAG))
((NOT NODDP)
(SETQ NODDP (LOADINSOMENUMAC Z))
(CPUSH ARGNO)
#%(OUTFS INST NODDP '1))
('T (SETQ NODDP #%(ILOCF Z))
(REMOVE Z)
(COND (#%(ACLOCP NODDP) (CPUSH NODDP) (CPUSH ARGNO))
((CPUSH-DDLPDLP ARGNO NODDP) (SETQ NODDP (1- NODDP))))
(OUT3 (ASSQ INST '((SKIPE) (SKIPG) (SKIPL) (SKIPN) (SKIPLE) (SKIPGE)))
0
NODDP))))
(COMPW (CADDR EXP) () (FREENUMAC))
(CDR (ASSQ (CAR EXP) '((ZEROP . (JUMPE . SKIPE))
(PLUSP . (JUMPG . SKIPG))
(MINUSP . (JUMPL . SKIPL))
(ODDP . (TRNN . TRNN)))))
(NOT (EQ (CAR EXP) 'ODDP))))
(DEFUN COM-X-C-R (X Y)
#%(LET (HNK LHNK VAL LVAL INDEX I-QTD-P (I 0))
#%(LET (EFFS (ARGNO 1))
(SETQ INDEX (COMP0 (NTH 0 Y)) HNK (COMP0 (NTH 1 Y)))
(SETQ I-QTD-P (COND ((NOT (EQ (CAR INDEX) 'QUOTE)) () )
((FIXP (CADR INDEX)))
((OR (ATOM (CADR INDEX))
(NOT (EQ (CAADR INDEX) SQUID)))
(PDERR (CONS X Y)
|Non-numeric index for CXR/RPLACX|)
())))
(AND (EQ X 'RPLACX)
(SETQ ARGNO 2
VAL (COMP0 (NTH 2 Y))
VAL (MAKESAFE VAL #%(ILOCREG VAL 2) () ))))
(COND ((NOT I-QTD-P)
;Insure that INDEX is in the slotlist
(ILOCMODE INDEX #%(NUMVALAC) 'FIXNUM)
(SETQ LHNK 1))
((AND (NOT EFFS)
(NOT #%(NUMACP-N ARGNO))
(COND ((NOT (DVP ARGNO)))
('T (CPUSH1 ARGNO 'CLEARVARS () )
(NOT (DVP1 SLOTX ARGNO)))))
(SETQ LHNK ARGNO))
(#%(ACLOCP (SETQ LHNK (ILOC0 HNK () ))))
('T (SETQ LHNK (FRAC1)) ))
;Be sure that the "hunk" (and "value" if RPLACX) gets into a REGAC
(COND ((AND (EQ X 'RPLACX) (NOT I-QTD-P))
#%(LET ((HLAC 2))
(LOADAC VAL 2 () )
(LOADAC HNK 1 () )
(SETQ LVAL 2)))
('T (LOADAC HNK LHNK () )
(COND ((EQ X 'RPLACX)
(OR #%(ACLOCP (SETQ LVAL (ILOC0 VAL () )))
#%(LET* ((SAVSLOT (FIND LHNK))
(SAVHNK (CAR SAVSLOT)))
(RPLACA SAVSLOT '(NIL . TAKEN))
(SETQ LVAL (COND ((= LHNK 1) (FRAC5))
((FRAC1))))
(RPLACA SAVSLOT SAVHNK)))
(LOADAC VAL LVAL () )) )))
(COND (I-QTD-P
(AND (OR (< (SETQ I (CADR INDEX)) 0) (> I 1023.))
(PDERR (CONS X Y) |Index out of range - CXR/RPLACX|))
(REMOVE INDEX)
(COND ((EQ X 'RPLACX)
#%(OUTFS (COND ((ODDP I) 'HRLM) ('HRRM))
LVAL
(LSH I -1)
LHNK))
('T #%(OUTFS (COND ((ODDP I) 'HLRZ) ('HRRZ))
LHNK
(LSH I -1)
LHNK))))
('T (LOADAC INDEX #%(NUMVALAC) () )
(OUTPUT (COND ((EQ X 'RPLACX) '(JSP T %RPX))
('T '(JSP T %CXR))))
#%(NULLIFY-NUMAC) ))
LHNK))
Reference in New Issue View Git Blame Copy Permalink