github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-01-26 12:12:12 +00:00
Code Issues Releases Wiki Activity

Updated to build compiler from source.

Browse Source 
Resolves #383.
This commit is contained in:
Eric Swenson
2017-01-18 16:14:13 -08:00
committed by Lars Brinkhoff
parent ab9c93fbba
commit c72c810b2f
10 changed files with 11433 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

228
src/comlap/cdmacs.40 Executable file
View File

@@ -0,0 +1,228 @@
;;; CDMACS -*-LISP-*-
;;; **************************************************************
;;; ***** MACLISP ** (Declarations and Macros for COMPLR) ********
;;; **************************************************************
;;; ** (C) Copyright 1981 Massachusetts Institute of Technology **
;;; ****** This is a Read-Only file! (All writes reserved) *******
;;; **************************************************************
(SETQ CDMACSVERNO '#.(let* ((file (caddr (truename infile)))
(x (readlist (exploden file))))
(setq |verno| (cond ((fixp x) file) ('/40)))))
(EVAL-WHEN (COMPILE)
(AND (OR (NOT (GET 'COMPDECLARE 'MACRO))
(NOT (GET 'OUTFS 'MACRO)))
(LOAD `(,(cond ((status feature ITS) '(DSK COMLAP))
('(LISP)))
CDMACS
FASL)))
)
(COMMENT MACROS WHICH DO DECLARATIONS FOR COMPLR ITSELF)
(EVAL-WHEN (COMPILE) (MACROS 'T))
(DEFUN COMPDECLARE MACRO (L)
(SPECIAL
ACSMODE ARGLOC ARGNO ARITHP ARRAYOPEN ASSEMBLE ATPL ATPL1 BVARS
CAAGL CARCDR CCLOAD:INITIAL-PROPS CDMACSVERNO CDUMP CFVFL
CHOMPHOOK CL CLEANUPSPL CLOSED CLPROGN CMSGFILES CNT COBARRAY COMAL
COMAUXVERNO COMP COMPILATION-FLAGCONVERSION-TABLE COMPILER-STATE
COMPLRVERNO CONDP CONDPNOB CONDTYPE CONDUNSF CREADTABLE CTAG DATA
DISOWNED EFFS EOC-EVAL EOF-COMPILE-QUEUE EOF-SEEN ERRFL EXIT EXITN
EXLDL EXPAND-OUT-MACROS EXPR-HASH EXTEND-FILES-TO-LOAD FASL FASLPUSH
FBARP FILEPOSIBLE FILESCLOSEP FIXSW FLOSW FLPDL FXPDL GAG-ERRBREAKS
GENPREFIX GFYC GL GOBRKL GOFOO GONE2 HLAC HUNK2-TO-CONS IDENTITY
IGNOREVARS IMOSAR INFILE INITIALIZE INITIAVERNO INMLS INSTACK IOBARRAY
IREADTABLE KTYPE L-END-CNT LAP-INSIGNIF LAPLL LAPOF LDLST LERSTP+1
LINEL LINEMODEP LMBP LOCVARS LOUT LOUT1 LPASST-FXP LPASST-P+1 LPRSL
MACROLIST MACROS MAKLAP-DEFAULTF-STYLE MAKLAPVERNO MAKUNBOUND MAPEX
MAPSB MCX-TRACE MODELIST MSDEV MSDIR MUZZLED NEW-EXTEND-FILES-TO-LOAD
NLNVS NLNVTHTBP NOLAP NULFU NUMACS OLVRL ONMLS OPSYS OPVRL
OUTFILES P1CCX P1CSQ P1GFY P1LL P1LLCEK P1LSQ P1PCX P1PSQ
P1SPECIALIZEDVS P2P PHAS1VERNO PKTYP PNOB PRATTSTACK PROGN PROGP
PROGTYPE PROGUNSF PRSSL PVR PVRL QSM QUIT-ON-ERROR READ RECOMPL REGACS
REGPDL RNL ROSENCEK RUNTIME-LIMIT RUNTIME-LIMITP
SAIL-MORE-SYSFUNS SAVED-ERRLIST SFLG SLOTX SOBARRAY
SPECIAL SPECIALS SPECVARS SPLDLST SPLITFILE-HOOK SQUID SREADTABLE STATE
STSL SWITCHLIST SWITCHTABLE SYMBOLS TAKENAC1 TOPFN TTYNOTES TYO UNDFUNS
UNFASLCOMMENTS UNSFLST UREAD USE-STRT7 USERATOMS-HOOKS
USERATOMS-INTERN USERATOMS-INTERN-FROB USER-STRING-MARK-IN-FASL
UWRITE VGO VGOL VL YESWARNTTY
)
(*FEXPR
*EXPR *FEXPR *LEXPR ARRAY* CGOL EREAD EVAL-WHEN FIXNUM FLONUM
INITIALIZE MAKLAP NOTYPE SPECIAL UNSPECIAL
)
(FIXNUM
AC ARGNO BASE BESTCNT BESTLOC CNT HLAC IBASE I II
LINEL M N NARGS NLARG NOACS P1CNT RSTNO TAKENAC1 VALAC
)
(FIXNUM
(COM-AREF) (CC0) (CLLOC) (COML1) (COMLC) (COMARRAY)
(CONVNUMLOC FIXNUM) (FRAC) (FRAC1) (FRAC5) (FRACB)
(FREENUMAC0) (FREENUMAC1) (FREENUMAC) (FREEREGAC)
(LOADINREGAC) (LOADINSOMENUMAC) (LOADINNUMAC NOTYPE FIXNUM)
(OUTFUNCALL) (P1TRESS) (ZTYI)
)
(*EXPR CARCDR CC0 CLEANUPSPL COMP COMPLRVERNO MCX-TRACE NARGS
P1GFY P1SPECIALIZEDVS SPECIALS UNSAFEP ELOAD UGREAT1
)
(*LEXPR PNAMECONC CDUMP EOPEN)
(APPLY 'ARRAY* (SUBST () () '((NOTYPE (BOLA 9 7) (STGET 10.) (CBA 16.)
(PVIA 3 17.) (A1S1A ? 4)
(AC-ADDRS 11.) (PDL-ADDRS 3 193.)))))
(FIXSW 'T) (CLOSED () ) (GENSYM 0)
(SETQ USE-STRT7 'T)
'(COMMENT COMPDECLARE))
(DEFUN FASLDECLARE MACRO (L)
(SPECIAL
ALLATOMS AMBIGSYMS ATOMINDEX BINCT CURRENTFN CURRENTFNSYMS DDTSYMP
DDTSYMS ENTRYNAMES EXPR FASLEVAL FASLPUSH FASLVERNO FILOC FSLFLD
IMOBFL IMOSAR IMOUSR LASTENTRY LDFNM LITCNT LITERALP LITERALS
LITLOC *LOC MAINSYMPDL MAKUNBOUND MESSIOC MSDIR SQUIDP SYMBOLSP
SYMPDL UFFIL UNDEFSYMS UNFASLCOMMENTS UNFASLSIGNIF
)
(*EXPR
*DDTSYM ARGSINFO ATOMINDEX BLOBLENGTH BUFFERBIN COLLECTATOMS
FASLDEFSYM FASLDIFF FASLEVAL FASLINIT FASLMAIN FASLMINUS
FASLNEGLIS FASLPASS1 FASLPASS2 FASLPLUS FASLVERNO
INDENT-TO-INSTACK LAPCONST LISTOUT LREMPROP MAKEWORD MESOUT
MOBYSYMPOP MSOUT MUNGEABLE REMPROPL SUBMATCH
)
(FIXNUM (BLOBLENGTH) (ATOMINDEX) (ARGSINFO)
(RECLITCOUNT) FILOC *LOC LITLOC LITCNT BINCT)
(ARRAY* (NOTYPE (LCA 16.) (BSAR 9.) (NUMBERTABLE 127.))
(FIXNUM (BTAR 9.) (BXAR 9.)))
(MAPEX T)
'(COMMENT FASLDECLARE))
(COMMENT MACROS THAT COULD BE IN-LINEABLE-EXPRS)
(DECLARE (MACROS () )
(SETQ DEFMACRO-CHECK-ARGS () )
(SETQ DEFMACRO-DISPLACE-CALL () )
(SETQ DEFMACRO-FOR-COMPILING 'T))
(DEFMACRO OUTFS (a1 a2 a3 &optional a4 a5)
(cond ((null a4) `(OUT3FIELDS ,a3 ,a2 ,a1))
((null a5) `(OUT4FIELDS ,a4 ,a3 ,a2 ,a1))
('t `(OUT5FIELDS ,a5 ,a4 ,a3 ,a2 ,a1))))
(DEFMACRO NCDR (l n) `(NTHCDR ,n ,l))
(DEFMACRO EQUIV (a1 a2) `(COND (,a1 ,a2) ((NULL ,a2))))
(DEFMACRO /2^N-P (n) `(ZEROP (BOOLE 4 ,n (- ,n))))
(DEFMACRO INVERSE-ASCII (char) `(GETCHARN ,char 1))
(DEFMACRO |Oh, FOO!| () `(OUTPUT 'FOO))
(DEFMACRO ITSP () `(EQ OPSYS 'ITS))
(DEFMACRO SAILP () `(EQ OPSYS 'SAIL))
(DEFMACRO DEC10P () `(EQ OPSYS 'DEC10))
(DEFMACRO DEC20P () `(EQ OPSYS 'DEC20))
(DEFMACRO BARF (item msg &OPTIONAL a1 a2) `(MSOUT ,item ',msg 'BARF ,a1 ,a2))
(DEFMACRO DBARF (item msg &OPTIONAL a1 a2) `(MSOUT ,item ',msg 'DATA ,a1 ,a2))
(DEFMACRO WARN (item msg &OPTIONAL a1 a2) `(MSOUT ,item ',msg 'WARN ,a1 ,a2))
(DEFMACRO PDERR (item msg) `(MSOUT ,item ',msg 'ERRFL 4 6))
(DEFMACRO KNOW-ALL-TYPES (a1)
`(COND ((NULL ,a1) () )
((MEMQ ,a1 '(FIXNUM FLONUM)))
((NOT (MEMQ '() ,a1)))))
(DEFMACRO INITIALSLOTS ()
`'((() () () () () ) ;REGACS
(() () () ) ;NUMACS
(() () () ) ;ACSMODE
() ;REGPDL
() ;FXPDL
() ;FLPDL
))
(DEFMACRO ERL-SET ()
`(OR (MEMBER '(COMPLRVERNO) (SETQ ERRLIST SAVED-ERRLIST))
(PUSH '(COMPLRVERNO) ERRLIST)))
(DEFMACRO SETUP-CATCH-PDL-COUNTS ()
`(SETQ LERSTP+1 13. LPASST-P+1 6. LPASST-FXP 11.))
(DEFMACRO CLEARALLACS () `(CLEARACS0 'T))
(DEFMACRO NO-DELAYED-SPLDS () `(CSLD (SETQ CCSLD 'T) 'T ()))
(DEFMACRO MAX-NPUSH () `'16.)
(DEFMACRO MAX-0PUSH () `'8)
(DEFMACRO MAX-0*0PUSH () `'8)
(DEFMACRO NACS () `'5)
(DEFMACRO NUMVALAC () `'7)
(DEFMACRO NUMNACS () `'3)
(DEFMACRO NACS+1 () `'#.(1+ (NACS)))
(DEFMACRO FXP0 () `'-2048.) ;2^11. Bit implies REGPDL
(DEFMACRO FLP0 () `'-4096.) ;2^12. Bit (with 2^11. off) implies FXPDL
(DEFMACRO NPDL-ADDRS () `'192.)
(DEFMACRO REGADP-N (n) `(LESSP #.(FXP0) ,n #.(NUMVALAC)))
(DEFMACRO REGACP (x) `(AND (SIGNP G ,x) (< ,x #.(NUMVALAC))))
(DEFMACRO REGACP-N (n) `(LESSP 0 ,n #.(NUMVALAC)))
(DEFMACRO REGPDLP-N (n) `(LESSP #.(FXP0) ,n 1))
(DEFMACRO REGPDLP (x) `(AND (SIGNP LE ,x) (> ,x #.(FXP0))))
(DEFMACRO PDLLOCP (x) `(SIGNP LE ,x))
(DEFMACRO PDLLOCP-N (n) `(NOT (> ,n 0)))
(DEFMACRO ACLOCP (x) `(SIGNP G ,x))
(DEFMACRO ACLOCP-N (n) `(> ,n 0))
(DEFMACRO NUMACP (x) `(AND (SIGNP G ,x) (NOT (< ,x #.(NUMVALAC)))))
(DEFMACRO NUMACP-N (n) `(NOT (< ,n #.(NUMVALAC))))
(DEFMACRO NUMPDLP (x) `(AND (SIGNP LE ,x) (NOT (> ,x #.(FXP0)))))
(DEFMACRO NUMPDLP-N (n) `(NOT (> ,n #.(FXP0))))
(DEFMACRO FLPDLP-N (n) `(NOT (> ,n #.(FLP0))))
(DEFMACRO PDLAC (mode)
`(COND ((EQ ,mode 'FIXNUM) 'FXP)
((NULL ,mode) 'P)
('FLP)))
(DEFMACRO PDLGET (mode)
`(COND ((EQ ,mode 'FIXNUM) FXPDL)
((NULL ,mode) REGPDL)
(FLPDL)))
(DEFMACRO ACSGET (mode) `(COND (,mode NUMACS) (REGACS)))
(DEFMACRO ACSSLOT (n)
`(COND ((= ,n #.(NUMVALAC)) NUMACS)
((= ,n #.(1+ (NUMVALAC))) (CDR NUMACS))
('T (CDDR NUMACS))))
(DEFMACRO ACSMODESLOT (n)
`(COND ((= ,n #.(NUMVALAC)) ACSMODE)
((= ,n #.(1+ (NUMVALAC))) (CDR ACSMODE))
('T (CDDR ACSMODE))))
(DEFMACRO NACSGET (mode)
`(COND ((NULL ,mode) #.(1+ (NACS)))
('T #.(1+ (NUMNACS)))))
(DEFMACRO NULLIFY-NUMAC ()
`(PROG2 (RPLACA NUMACS () ) () (RPLACA ACSMODE () )))
(DEFMACRO ILOCREG (x acx) `(ILOCMODE ,x ,acx '(() FIXNUM FLONUM)))
(DEFMACRO ILOCNUM (x acx) `(ILOCMODE ,x ,acx '(FIXNUM FLONUM)))
(DEFMACRO ILOCF (x) `(ILOCMODE ,x 'FRACF '(() FIXNUM FLONUM)))
(DEFMACRO ILOCN (x) `(ILOCMODE ,x 'ARGNO '(() FIXNUM FLONUM)))
(DEFMACRO FREACB () `(FREEREGAC 'FRACB))
(DEFMACRO FREAC () `(FREEREGAC 'FRAC))

2379
src/comlap/comaux.25 Executable file
View File

File diff suppressed because it is too large Load Diff

3061
src/comlap/complr.936 Executable file
View File

File diff suppressed because it is too large Load Diff

860
src/comlap/faslap.392 Executable file
View File

@@ -0,0 +1,860 @@
;;; FASLAP -*-LISP-*-
;;; **************************************************************
;;; ***** MacLISP ****** (Assembler for compiled code) ***********
;;; **************************************************************
;;; ** (C) Copyright 1981 Massachusetts Institute of Technology **
;;; ****** This is a read-only file! (All writes reserved) *******
;;; **************************************************************
(SETQ FASLVERNO '#.(let* ((file (caddr (truename infile)))
(x (readlist (exploden file))))
(setq |verno| (cond ((fixp x) file) ('/392)))))
(EVAL-WHEN (COMPILE)
(AND (OR (NOT (GET 'COMPDECLARE 'MACRO))
(NOT (GET 'OUTFS 'MACRO)))
(LOAD `(,(cond ((status feature ITS) '(DSK COMLAP))
('(LISP)))
CDMACS
FASL)))
)
;;; This assembler is normally part of the compiler, and produces
;;; binary (FASL) files suitable for loading with FASLOAD.
(EVAL-WHEN (COMPILE) (COMPDECLARE) (FASLDECLARE) (GENPREFIX |/|fl|) )
(DEFUN FASLVERNO ()
(PRINC '|/îFASLAP Assembler |)
(PRINC FASLVERNO)
(PRINC '| |))
(DEFUN FASLIFY (LL FL)
(PROG (Y)
(COND ((EQ FL 'LIST))
((OR (EQ FL 'LAP)
(AND (NULL FL) (NOT (ATOM LL)) (EQ (CAR LL) 'LAP)))
(DO ((Z LL (AND ^Q (READ EOF))) (EOF (LIST ())))
((NULL Z) (SETQ LL (NREVERSE (CONS () Y))))
(AND (NULL ^Q)
(PROG2 (PDERR CURRENTFN |Has EOF in middle of LAP code|)
(ERR 'FASLAP)))
(PUSH Z Y)))
(FL (SETQ FBARP 'T)
(BARF () |FASLIFY is losing|))
(T (SETQ Y LL LL ()) (GO B)))
A (AND (NULL LL) (RETURN ()))
(SETQ Y (CAR LL))
B (COND ((ATOM Y)) ;IGNORE RANDOM ATOMS
((EQ (CAR Y) 'LAP) ;PROCESS LAP
(SETQ CURRENTFN (CADR Y))
(FASLPASS1 LL)
(SETQ LL (FASLPASS2 LL))
(SETQ FILOC (+ FILOC *LOC))
(AND (NOT (EQ COMPILER-STATE 'COMPILE))
TTYNOTES
(PROG (^W ^R)
(INDENT-TO-INSTACK 0)
(PRIN1 CURRENTFN)
(PRINC '| Assembled|))))
((MUNGEABLE Y) (COLLECTATOMS Y) (BUFFERBIN 14. -1_18. Y))
(T (COND ((EQ (CAR Y) 'DECLARE)
(ERRSET (MAPC 'EVAL (CDR Y)) ())
(SETQ Y ()))
((OR (EQ (CAR Y) 'COMMENT) (NOT (EQ (CAR Y) 'QUOTE))))
((SUBMATCH (CADR Y) '(THIS IS THE LAP FOR))
(SETQ Y
(AND UNFASLCOMMENTS
(SUBST (CADDDR (CDDADR Y))
'DATA
''(THIS IS THE UNFASL
FOR LISP FILE DATA)))))
((SUBMATCH (CADR Y) '(COMPILED BY LISP COMPILER))
(SETQ Y ())))
(COND ((AND Y (OR UNFASLCOMMENTS
(NOT (MEMQ (CAR Y) '(COMMENT QUOTE)))))
((LAMBDA (^R ^W OUTFILES)
(TERPRI) ;PUT NON-MUNGEABLE INTO UNFASL FILE
(COND ((AND (NOT (ATOM Y))
(EQ (CAR Y) 'QUOTE))
(PRINC '/') (SETQ Y (CADR Y))))
(PRIN1 Y) (PRINC '/ ))
T T UFFIL)
(SETQ UNFASLSIGNIF T)))))
(SETQ LL (CDR LL))
(GO A)))
;;; FASLPASS1 PERFORMS PASS 1 PROCESSING FOR A LAP FUNCTION.
;;; THIS INCLUDES DEFINING SYMBOLS, doing the COLLECTATOMS work for
;;; most address fields [e.g., for xxx in (OP AC xxx IDX)], so that
;;; the USERATOMS-HOOK wont ever have to cause auotloadings during
;;; the middle of a function, AND SAVING VARIOUS PIECES
;;; OF INFORMATION FOR PASS 2.
(DEFUN FASLPASS1 (Q) ;Q HAS (LAP FOO SUBR) OR WHATEVER
((LAMBDA (BASE IBASE)
(PROG (AMBIGSYMS N EXPR)
(AND (NOT (EQ (CAAR Q) 'LAP))
(SETQ FBARP 'T)
(DBARF Q |Not a LAP listing - FASLPASS1|))
(SETQ *LOC 0)
(SETQ CURRENTFN (CADAR Q) CURRENTFNSYMS ())
(PUSH CURRENTFN ENTRYNAMES)
(PUTPROP CURRENTFN FILOC 'ENTRY)
(AND UNFASLCOMMENTS (NOTE-IN-UNFASL FILOC (CAR Q) ())) ;Tells about entry points
(DO Z (CDR Q) (CDR Z) (COND ((NULL Z)
(DBARF () |No () [or "NIL"] in LAP code - FASLPASS1|)
(SETQ FBARP 'T))
((NULL (SETQ EXPR (CAR Z)))))
(COND ((ATOM EXPR)
(FASLDEFSYM EXPR (LIST 'RELOC (+ FILOC *LOC))))
((EQ (CAR EXPR) 'ENTRY)
(COND ((GET (CADR EXPR) 'ENTRY)
(PDERR CURRENTFN |Multiple ENTRY with duplicated name|)
(ERR 'FASLAP))
(T (PUSH (CADR EXPR) ENTRYNAMES)
(PUTPROP (CADR EXPR) (SETQ DATA (+ FILOC *LOC)) 'ENTRY)
(AND UNFASLCOMMENTS
(NOTE-IN-UNFASL DATA EXPR () )))))
((EQ (CAR EXPR) 'DEFSYM) ;DEFSYM
(DO X (CDR EXPR) (CDDR X) ;SO DEFINE THE SYMBOLS
(NOT (AND X (CDR X))) ;NOTE THAT EVAL IS USED,
(FASLDEFSYM (CAR X) (EVAL (CADR X))))) ; NOT FASLEVAL
((EQ (CAR EXPR) 'DDTSYM) ;DECLARE DDT SYMBOLS
(SETQ DDTSYMP T) ;REMEMBER THAT THIS FN HAD DDTSYM
(MAPC (FUNCTION *DDTSYM) (CDR EXPR))) ;TRY TO GET THEM FROM DDT
((EQ (CAR EXPR) 'EVAL) ;EVALUATE RANDOM FROBS
(MAPC (FUNCTION EVAL) (CDR EXPR)))
((EQ (CAR EXPR) 'SYMBOLS) ;SYMBOLS - FOR NOW, JUST
(SETQ SYMBOLSP T)) ; REMEMBER THAT ONE HAPPENED
((MEMQ (CAR EXPR) '(SIXBIT ASCII BLOCK)) ;HAIRY BLOBS
(SETQ *LOC (+ *LOC (SETQ N (BLOBLENGTH EXPR)))))
((NOT (MEMQ (CAR EXPR) '(COMMENT ARGS)))
(RECLITCOUNT EXPR T)
(SETQ *LOC (1+ *LOC)))))
(SETQ LITLOC *LOC) ;REMEMBER WHERE TO ASSEMBLE LITERALS
(SETQ LITERALS (NREVERSE LITERALS))))
8. 8.))
(DEFUN RECLITCOUNT (insn PASS1P)
;;On pass 1, merely ascertain number of code words using literals, and
;; check the COLLECTATOMS problem
(COND ((AND (CDDR insn)
(SETQ insn (COND ((OR (EQ (CADDR insn) '/@)
(EQ (CADR insn) '/@))
(CADDDR insn))
((CADDR insn))))
;; Note that this lets HUNKs go thru
(NOT (ATOM insn)))
(COND ((NOT (EQ (CAR insn) '%))
(cond ((or (memq (car insn) '(QUOTE FUNCTION SPECIAL ARRAY
EVAL SQUID))
(eq (car insn) SQUID))
(collectatoms (cadr insn))))
0)
((LAPCONST (CDR insn)) 0)
(PASS1P
;;On pass1, not really interested in count
(and (not (eq pass1p 'COLLECTATOMS))
(PUSH (CDR insn) LITERALS))
(reclitcount (cdr insn) 'COLLECTATOMS)
0)
((MEMQ (CADR insn) '(SIXBIT ASCII BLOCK))
(BLOBLENGTH (cdr insn)))
((1+ (RECLITCOUNT (cdr insn) () )))))
(0)))
;;; FASLPASS2 PERFORMS PASS 2 PROCESSING FOR A LAP FUNCTION.
;;; THIS INCLUDES RETRIEVING INFORMATION SAVED ON PASS 1
;;; (IN PARTICULAR SYMBOLS), HANDLING DDT SYMBOLS TO BE
;;; RETRIEVED AT LOAD TIME, PROCESSING LITERALS, DEFINING
;;; ENTRY POINTS TO THE LOADER, AND OF COURSE CONVERTING
;;; INSTRUCTIONS TO BINARY CODE. THE FUNCTION MAKEWORD IS
;;; CALLED TO PROCESS INDIVIDUAL LAP STATEMENTS.
(DEFUN FASLPASS2 (Q) ;Q HAS LAP LISTING
((LAMBDA (BASE IBASE LITCNT)
(PROG (DDTSYMS AMBIGSYMS LASTENTRY ENTRYPOINTS LITERALP
UNDEFSYMS OLOC EXPR OLITERALS LL N TEM)
(SETQ OLITERALS LITERALS OLOC *LOC *LOC 0)
(COLLECTATOMS (CDR (SETQ EXPR (CAR Q)))) ;MUST COLLECT NAME AND TYPE OF SUBR
(PUSH (CONS (CONS (CADR EXPR) (CADDR EXPR)) (GET CURRENTFN 'ENTRY))
ENTRYPOINTS) ;SAVE ENTRY POINT INFO
(COND ((GET CURRENTFN 'SYMBOLSP) ;SYMBOLS PSEUDO ANYWHERE MAKES ENTRY DEFINED
(BUFFERBIN 13. 0 CURRENTFN))) ; - OUTPUT AS DDT SYMBOL
(SETQ LASTENTRY CURRENTFN)
(DO Z (CDR Q) (CDR Z) (COND ((NULL (SETQ EXPR (CAR Z)))
(SETQ LL Z)
T))
(COND ((ATOM EXPR) ;MAYBE A TAG SHOULD BE
(COND (SYMBOLSP (BUFFERBIN 13. 0 EXPR)))) ; OUTPUT AS A DDT SYMBOL
((EQ (CAR EXPR) 'ENTRY) ;ENTRY POINT
(COND ((NOT (= (SETQ N (+ FILOC *LOC))
(GET (CADR EXPR) 'ENTRY))) ;BETTER BE AT
(BARF (CADR EXPR) |Phase screw at ENTRY - FASLPASS2|)))
(COLLECTATOMS (CDR EXPR)) ;COLLECT NAME AND TYPE
(PUSH (CONS (CONS (CADR EXPR) ;SAVE INFO ABOUT ENTRY
(COND ((CDDR EXPR)
(CADDR EXPR))
((CADDAR Q))))
N)
ENTRYPOINTS)
(AND SYMBOLSP (BUFFERBIN 13. 0 (CADR EXPR)))
(SETQ LASTENTRY (CADR EXPR)))
((EQ (CAR EXPR) 'ARGS) ;ARGS DECLARATION
(COND ((EQ (CADR EXPR) LASTENTRY) ;SHOULD BE JUST AFTER ENTRY
(PUTPROP (CADR EXPR) (CADDR EXPR) 'ARGSINFO)) ;SAVE INFO
('T (COND ((GET (CADR EXPR) 'ENTRY) ;TWO WAYS TO BARF AT LOSER
(PDERR EXPR |Misplaced ARGS info|))
((PDERR EXPR |Function not seen for this info|)))
(ERR 'FASLAP)) ))
((EQ (CAR EXPR) 'SYMBOLS) ;TURN DDT SYMBOLS OUTPUT
(SETQ SYMBOLSP (CADR EXPR))) ; SWITCH ON OR OFF
((EQ (CAR EXPR) 'EVAL) ;EVALUATE RANDOM FROBS
(MAPC (FUNCTION EVAL) (CDR EXPR)))
((EQ (CAR EXPR) 'DDTSYM) ;SAVE DDTSYMS TO PUT
(MAPC '(LAMBDA (X) (AND (NOT (MEMQ X DDTSYMS)) (PUSH X DDTSYMS)))
(CDR EXPR)))
((NOT (MEMQ (CAR EXPR) '(DEFSYM COMMENT))) (MAKEWORD EXPR))))
(AND (OR LITERALS (NOT (= *LOC LITLOC))) (GO PHAS))
(SETQ LITERALP T) ;THIS LETS FASLEVAL KNOW WE'RE DOING LITERALS
(MAPC (FUNCTION MAKEWORD) OLITERALS) ;SO ASSEMBLE ALL THEM LITERALS
(AND (NOT (= *LOC (+ LITLOC LITCNT))) (GO PHAS))
(MAPC '(LAMBDA (X)
(SETQ TEM (GET (CAAR X) 'ARGSINFO))
(BUFFERBIN 11. (BOOLE 7 (LSH (ARGSINFO (CAR TEM)) 27.)
(LSH (ARGSINFO (CDR TEM)) 18.)
(CDR X))
(CAR X)))
ENTRYPOINTS)
(AND DDTSYMS ;BARF ABOUT DDT SYMBOLS
(COND ((NULL DDTSYMP)
(WARN DDTSYMS |Undefined symbols - converted to DDT symbols|))
((WARN DDTSYMS |DDT symbols|))))
(AND UNDEFSYMS (PROG2 (PDERR UNDEFSYMS |Undefined symbols|)
(ERR 'FASLAP)))
(REMPROPL 'SYM CURRENTFNSYMS)
(REMPROPL 'SYM DDTSYMS)
(MOBYSYMPOP SYMPDL) ;RESTORE DISPLACED SYMBOLS
(RETURN LL) ;NORMAL EXIT
PHAS (BARF () |Literal phase screw|)))
8. 8. 0))
(DEFUN ARGSINFO (X) (COND ((NULL X) 0) ((= X 511.) X) ((1+ X))))
;;; FASLEVAL IS ONLY USED BY MAKEWORD, TO EVALUATE THE
;;; FIELDS OF A LAP INSTRUCTION.
(DEFUN FASLEVAL (X) ;EVALUATE HAIRY FASLAP EXPRESSION
(COND ((NUMBERP X) X) ;A NUMBER IS A NUMBER IS A NUMBER
((ATOM X)
(COND ((EQ X '*) (LIST 'RELOC (+ FILOC *LOC))) ;* IS THE LOCATION COUNTER
((GET X 'GLOBALSYM)) ;TRY GETTING GLOBARSYM PROP
((GET X 'SYM)) ;TRY GETTING SYM PROPERTY
((OR (NULL X) (MEMQ X UNDEFSYMS)) 0) ;0 FOR LOSING CASES
(((LAMBDA (Y) (AND Y (PUTPROP X Y 'SYM))) (GETMIDASOP X)))
((NULL DDTSYMP) ;MAYBE CAN PASS THE BUCK ON
(PUSH X DDTSYMS) ; TO FASLOAD (IT WILL GET
(*DDTSYM X)) ; SYMBOL FROM DDT WHEN LOADING)
(T (PUSH X UNDEFSYMS) 0))) ;OH, WELL, GUESS IT'S UNDEFINED
((EQ (CAR X) 'QUOTE)
(COND ((ATOM (CADR X)) X)
((EQ (CAADR X) SQUID)
(COND ((EQ (CADR (SETQ X (CADR X))) MAKUNBOUND)
'(0 (() 34)))
(X)))
((EQ (CDADR X) GOFOO) (LIST 'EVAL (CAADR X)))
(X)))
((OR (MEMQ (CAR X) '(SPECIAL FUNCTION ARRAY)) (EQ (CAR X) SQUID))
X)
((EQ (CAR X) 'EVAL) (CONS SQUID (CDR X)))
((EQ (CAR X) '%)
(COND ((NOT (= FSLFLD 1)) ;LITERALS MUST BE IN ADDRESS FIELD
(PDERR X |Literal not in address field|)
(ERR 'FASLAP))
((LAPCONST (CDR X))) ;MAYBE IT'S A LAP CONSTANT
((NOT LITERALP)
(SETQ LITERALS (CDR LITERALS)) ;KEEPING COUNT OF THE NUMBER OF LITERALS
((LAMBDA (RLC)
(SETQ LITCNT
(+ LITCNT
(COND ((MEMQ (CADR X) '(SIXBIT ASCII BLOCK))
(BLOBLENGTH (CDR X)))
((ZEROP (RECLITCOUNT (CDR X) ())) 1)
(T (SETQ RLC (+ RLC (RECLITCOUNT (CDR X) ())))
(- RLC LITCNT -1)))))
(LIST 'RELOC (+ FILOC LITLOC RLC)))
LITCNT))
((PROG2 () ;HO! HO! HO! YOU THINK THIS WILL WORK??
(FASLEVAL '*)
(MAKEWORD (CDR X))))))
((MEMQ (CAR X) '(ASCII SIXBIT)) ;A WORD OF ASCII
(CAR (PNGET (CADR X)
(COND ((EQ (CAR X) 'ASCII) 7) (6))))) ;OR OF SIXBIT
((EQ (CAR X) 'SQUOZE) ;A WORD OF SQUOZE [MAY BE EITHER
(SQOZ/| (CDR X))) ; (SQUOZE SYMBOL) OR (SQUOZE # SYMBOL)]
((EQ (CAR X) '-) ;SUBTRACTION (OR MAYBE NEGATION)
(COND ((NULL (CDDR X))
(FASLMINUS (FASLEVAL (CADR X))))
((FASLDIFF (FASLEVAL (CADR X))
(FASLEVAL (CDDR X))))))
((EQ (CAR X) '+) ;ADDITION
(FASLPLUS (FASLEVAL (CADR X))
(FASLEVAL (CDDR X))))
((CDR X) (FASLPLUS (FASLEVAL (CAR X)) ;A RANDOM LIST GETS ADDED UP
(FASLEVAL (CDR X))))
((FASLEVAL (CAR X))))) ;SUPERFLUOUS PARENS - RE-FASLEVAL
;;; THE VALUE OF FASLEVAL IS ONE OF THE FOLLOWING FROBS:
;;; <NUMBER> A NUMBER
;;; (<NUMBER> -GLITCHES-) NUMBER (PLUS GLITCHES)
;;; (RELOC <NUMBER> -GLITCHES-) RELOCATABLE VALUE (PLUS GLITCHES)
;;; (SPECIAL <ATOM>) REFERENCE TO VALUE CELL
;;; (QUOTE <S-EXPRESSION>) S-EXPRESSION CONSTANT
;;; (FUNCTION <ATOM>) REFERENCE TO FUNCTION [SAME AS (QUOTE <ATOM>)]
;;; (ARRAY <ATOM>) REFERENCE TO ARRAY POINTER
;;; FOO RESULT OF INVALID ARGS TO FASLEVAL
;;;
;;; A "GLITCH" IS ONE OF THE FOLLOWING:
;;; (() <NUMBER> . <SIGN>) GLOBALSYM [<NUMBER> INDICATES WHICH ONE]
;;; (<SQUOZE> () . <SIGN>) DDT SYMBOL, VALUE UNKNOWN [<SQUOZE> IS A NUMBER]
;;; (<SQUOZE> <VALUE> . <SIGN>) DDT SYMBOL, VALUE KNOWN TO DDT ABOVE FASLAP
;;; <SIGN> IS EITHER - FOR NEGATIVE OR () FOR POSITIVE.
;;;
;;; FASLPLUS, FASLMINUS, AND FASLDIFF ARE USED TO PERFORM ARITHMETIC ON THESE FROBS.
;;; NO ARITHMETIC CAN BE PERFORMED ON THE SPECIAL, QUOTE, FUNCTION, ARRAY, AND FOO FROBS.
;;; ARITHMETIC CAN BE PERFORMED ON ALL THE OTHERS, EXCEPT THAT ONE CANNOT CREATE
;;; A NEGATIVE RELOC FROB, I.E. ONE CAN SUBTRACT A RELOC FROM A RELOC, BUT NOT
;;; A RELOC FROM AN ABSOLUTE.
(DEFUN FASLPLUS (K Q) ;ADD TWO FROBS
(COND ((NUMBERP K)
(COND ((NUMBERP Q) (+ K Q))
((EQ (CAR Q) 'RELOC)
(CONS 'RELOC (CONS (+ K (CADR Q)) (CDDR Q))))
((NUMBERP (CAR Q))
(CONS (+ K (CAR Q)) (CDR Q)))
('FOO)))
((EQ (CAR K) 'RELOC)
(COND ((NUMBERP Q)
(CONS 'RELOC (CONS (+ Q (CADR K)) (CDDR K))))
((NUMBERP (CAR Q))
(CONS 'RELOC (CONS (+ (CAR Q) (CADR K))
(APPEND (CDR Q) (CDDR K)))))
('FOO)))
((NUMBERP (CAR K))
(COND ((NUMBERP Q)
(CONS (+ Q (CAR K)) (CDR K)))
((EQ (CAR Q) 'RELOC)
(CONS 'RELOC (CONS (+ (CAR K) (CADR Q))
(APPEND (CDR K) (CDDR Q)))))
((NUMBERP (CAR Q))
(CONS (+ (CAR K) (CAR Q))
(APPEND (CDR K) (CDR Q))))
('FOO)))
('FOO)))
(DEFUN FASLDIFF (K Q) ;SUBTRACT TWO FROBS
(COND ((NUMBERP K)
(COND ((NUMBERP Q) (- K Q))
((NUMBERP (CAR Q))
(CONS (- K (CAR Q)) (FASLNEGLIS (CDR Q))))
('FOO)))
((EQ (CAR K) 'RELOC)
(COND ((NUMBERP Q)
(CONS 'RELOC (CONS (- (CADR K) Q) (CDDR K))))
((EQ (CAR Q) 'RELOC)
(CONS (- (CADR K) (CADR Q))
(APPEND (CDDR K) (FASLNEGLIS (CDDR Q)))))
((NUMBERP (CAR Q))
(CONS 'RELOC
(CONS (- (CADR K) (CAR Q))
(APPEND (CDDR K)
(FASLNEGLIS (CDR Q))))))
('FOO)))
((NUMBERP (CAR K))
(COND ((NUMBERP Q)
(CONS (- (CAR K) Q) (CDR K)))
((NUMBERP (CAR Q))
(CONS (- (CAR K) (CAR Q))
(APPEND (CDR K) (FASLNEGLIS (CDR Q)))))
('FOO)))
('FOO)))
(DEFUN FASLMINUS (Q) ;NEGATE A FROB
(COND ((NUMBERP Q) (- Q))
((NUMBERP (CAR Q))
(CONS (- (CAR Q)) (FASLNEGLIS (CDR Q))))
('FOO)))
(DEFUN FASLNEGLIS (K) ;NEGATES A LIST OF GLITCHES
(MAPCAR (FUNCTION (LAMBDA (Q)
(CONS (CAR Q)
(CONS (CADR Q)
(COND ((CDDR Q) ())
('-))))))
K))
;;; LAPCONST IS A "SEMI-PREDICATE" WHICH WHEN APPLIED TO THE CDR
;;; OR A LITERAL DETERMINES WHETHER OR NOT IT IS ONE OF A NUMBER
;;; OF SPECIAL "LAP CONSTANTS" WHICH ARE DEFINED IN LISP (IN A
;;; TABLE AT LOCATION R70) SINCE COMPILED CODE USES THEM SO OFTEN.
;;; IF NOT, IT RETURNS (); IF SO, IT RETURNS A FASLEVAL FROB
;;; INDICATING A REFERENCE TO R70 AS A GLOBALSYM.
(DEFUN LAPCONST (X) ;SPECIAL LAP CONSTANTS ARE
(COND ((NOT (SIGNP E (CAR X)))
(AND (NULL (CDR X)) (LAPC1 (CAR X)))) ;(% '()), (% FIX1), OR (% FLOAT1)
((NULL (CDR X)) '(0 (() -1))) ;(% 0) OR (% 0.0)
((OR (NOT (FIXP (CADR X)))
(NOT (= (CADR X) 0))
(NULL (SETQ X (CDDR X))))
())
((NULL (CDR X)) (LAPC1 (CAR X))) ;(% 0 0 '()), (% 0 0 FIX1), OR (% 0 0 FLOAT1)
((AND (FIXP (CAR X))
(< (CAR X) 16. )
(> (CAR X) 0)
(FIXP (CADR X))
(= (CAR X) (CADR X)))
(LCA (CAR X))))) ;(% 0 0 N N) FOR 0 < N < 16.
(DEFUN LAPC1 (X)
(COND ((EQ X 'FIX1) '(-2 (() -1)))
((EQ X 'FLOAT1) '(-1 (() -1)))
((AND (EQ (TYPEP X) 'LIST) (EQ (CAR X) 'QUOTE) (EQ (CADR X) '())
'(0 (() -1))))))
;;; ATOMINDEX is used to retrieve the index of an atom (this
;;; index must have been previously defined by COLLECTATOMS).
;;; Symbol atoms have ATOMINDEX properties; indices of
;;; numbers are kept in a hash table called NUMBERTABLE.
(eval-when (eval compile)
(setq useratoms-non-types '(LIST SYMBOL FIXNUM FLONUM BIGNUM))
;; memorize x as a user-atom we've collected. Gets
;; (atom . index) as the argument
(defmacro USERATOMS-INTERN (x)
`(PUSH ,x USERATOMS-INTERN))
;; get the user-atom x's atomindex, or nil if it doesn't have one
(defmacro USERATOMS-LOOKUP (x)
`(CDR (ASSQ ,x USERATOMS-INTERN)))
)
(DEFUN ATOMINDEX (X TYPE)
(let ((user-index (if (not (memq type '#.useratoms-non-types))
(useratoms-lookup x))))
(cond ((not (null user-index)) user-index)
((null x) 0)
(T (and (null type) (setq type (typep x)))
(setq type (cond ((eq type 'symbol) (get x 'atomindex))
((not (memq type '(fixnum flonum bignum))) ())
((cdr (hassocn x type)))))
(and (null type) (barf x |Atomindex screw|))
type))))
;; COLLECTATOMS finds all atoms in an s-expression and assigns an atomindex
;; to each one which doesn't already have one. These index assignments are also
;; output into the binary file. It is through these indices that s-expressions
;; are described to the loader.
;; The hook USERATOMS-HOOKS if non-null should be a list of function to invoke
;; on each object being COLLECTATOMSed. If one returns non-null, the return
;; value should be the NCONS of the form to be EVAL'd to create the frob.
;;
;; See also ATOMINDEX
(defun COLLECTATOMS (x)
(do ((user-object nil nil)
(type) (marker))
((null x))
(cond ((null x) (return () )) ;() is always pre-collected
((eq (setq type (typep x)) 'LIST)
(collectatoms (car x))
(setq x (cdr x))) ;Loop until no more
((eq type 'SYMBOL)
(cond ((null (get x 'ATOMINDEX))
(push x allatoms)
(cond ((setq marker
(getl x '(+INTERNAL-STRING-MARKER
+INTERNAL-TEMP-MARKER)))
(setq user-object ;code to generate uninterned sym!
`(pnput ',(pnget x 7) nil))
(collectatoms user-object)
(setq user-object
`(,useratoms-intern-frob
,user-object
,x . ,(setq atomindex (1+ atomindex))))
(bufferbin 14. -2_18. user-object)
(putprop x (cdddr user-object) 'ATOMINDEX)
(cond ((eq (car marker) '+INTERNAL-STRING-MARKER)
(setq user-object ;Self-evaling, with marker
`(setq ,x ',x))
(collectatoms user-object)
(bufferbin 14. -1_18. user-object)))
(cond (user-string-mark-in-fasl
(setq user-object
`(DEFPROP ,x T ,(car marker)))
(collectatoms user-object)
(bufferbin 14. -1_18. user-object))))
('T (putprop x
(setq atomindex (1+ atomindex))
'atomindex)
(bufferbin 10. 0 x)))))
(return () ))
((memq type '(FIXNUM FLONUM BIGNUM))
(let ((bkt (hassocn x type)))
(cond ((null (cdr bkt))
(setq atomindex (1+ atomindex))
(rplacd bkt (list (cons type (cons x atomindex))))
(bufferbin 10. 0 x))))
(return () ))
;; Someday, it may be that we want to allow ordinary MacLISP
;; data types to be filtered thru this USERATOMS-HOOK, and the
;; next two clauses will have to be moved up to the beginning of
;; this COND then; but for now, it is verrrry slow.
((useratoms-lookup x) (return () )) ;Don't repeat
((and useratoms-hooks
(do ((hooks useratoms-hooks (cdr hooks)))
((or (null hooks)
(setq user-object (funcall (car hooks) x)))
user-object)))
;;Hunks will generally have a symbol in their CXR 1
(and (not (atom user-object)) (collectatoms (car user-object)))
(useratoms-intern `(,x . ,(setq atomindex (1+ atomindex))))
(bufferbin 14. -2_18.
`(,useratoms-intern-frob ,(car user-object)
,x . ,atomindex))
(return () )) ;No more
((hunkp x)
(do i (1- (hunksize x)) (1- i) (< i 0)
(collectatoms (cxr i x)))
(return () ))
(T (barf x |Unrecognizable datum -- Collectatoms|)))))
(DEFUN HASSOCN (X TYPE)
(PROG (BKT OBKT FIXFLOP I)
(SETQ FIXFLOP (MEMQ TYPE '(FIXNUM FLONUM)))
(SETQ I (\ (ABS (SXHASH X)) 127.))
(AND (MINUSP I) (SETQ I 0))
(SETQ OBKT (NUMBERTABLE I))
A (COND ((NULL (SETQ BKT (CDR OBKT)))
(RETURN (COND (OBKT) ;RETURN (<MUMBLE> . ())
((STORE (NUMBERTABLE I)
(LIST ())))))) ;THE "LAST" OF A BKT
((NOT (EQ TYPE (CAAR BKT))))
((COND ((NOT FIXFLOP) (EQUAL X (CADAR BKT)))
(T (= X (CADAR BKT))))
(RETURN (CDAR BKT)))) ;RETURN (N . INDEX)
(SETQ OBKT BKT)
(GO A)))
;;; FASLDEFSYM IS USED TO DEFINE SYMBOLS; IT ALSO CHECKS FOR VARIOUS
;;; ERRORS, INCONSISTENCIES, AND AMBIGUITIES.
(DEFUN FASLDEFSYM (SYM VAL) ;DEFINE A SYMBOL
(PROG (Z)
(COND ((GET SYM 'GLOBALSYM)
(PDERR SYM |Cant redefine a GLOBALSYM - FASLDEFSYM|)
(ERR 'FASLAP))
((SETQ Z (GET SYM 'SYM)) ;MAYBE IT'S ALREADY DEFINED?
(COND ((EQUAL Z VAL) (RETURN Z)) ;REDEFINING TO SAME VALUE DOESN'T HURT
((NOT (MEMQ SYM AMBIGSYMS)) ;ELSE IT IS AN AMBIGUOUS SYMBOL
(PUSH SYM AMBIGSYMS) ;OH, WE'LL REDEFINE IT, ALL RIGHT,
(AND (NOT (MEMQ SYM CURRENTFNSYMS)) ; BUT WE'LL ALSO BARF
(SETQ MAINSYMPDL (PUSH (CONS SYM Z) SYMPDL))))))
(T (PUSH SYM CURRENTFNSYMS)))
(RETURN (PUTPROP SYM VAL 'SYM)))) ;SO DEFINE THE SYMBOL (MUST RETURN THE VALUE)
(DEFUN BLOBLENGTH (X) ;DETERMINES LENGTH OF A BLOB
(COND ((EQ (CAR X) 'SIXBIT) ;SIXBIT
(// (+ 5 (FLATC (CADR X))) 6))
((EQ (CAR X) 'ASCII) ;ASCII (actually, ASCIZ)
(1+ (// (FLATC (CADR X)) 5)))
((NUMBERP (SETQ DATA (CADR X))) ;MUST BE BLOCK - ACCEPT NUMBER
DATA )
((AND (SYMBOLP DATA) ;ACCEPT SYMBOL With numeric VAL
(NUMBERP (SETQ DATA (GET DATA 'SYM))))
DATA)
(T (PDERR X |Undefined arg for block expression|)
(ERR 'FASLAP) )))
(DEFUN SUBMATCH (X Y) ;"true" IFF LIST Y IS A PREFIX OF LIST X
(DO ((X X (CDR X)) (Y Y (CDR Y)))
((NULL Y) T)
(AND (NULL X) (RETURN ())) ;X WAS TOO SHORT
(AND (NOT (EQ (CAR X) (CAR Y))) (RETURN ())))) ;THEY DONT MATCH
(DEFUN MUNGEABLE (X) ;SHOULD RANDOM S-EXPR BE PUT IN BINARY FILE
(NOT (OR (MEMQ (CAR X) '(QUOTE COMMENT DECLARE)) ;NOT IF QUOTED OR COMMENT
(AND (EQ (CAR X) 'EVAL) ;NOT IF (EVAL 'FOO)
(EQ (TYPEP (CADR X)) 'LIST) ; (THIS GIVES US A HOOK TO
(EQ (CAADR X) 'QUOTE))))) ; AVOID MUNGING IF DESIRED)
(DEFUN MOBYSYMPOP (L)
(DO X L (CDR X) (NULL X)
(PUTPROP (CAAR X) (CDAR X) 'SYM)))
;;; LISTOUT OUTPUTS AN S-EXPRESSION AS A SEQUENCE OF LIST-SPECS.
;;; EACH LIST-SPEC MAY BE AS FOLLOWS:
;;; 0,,N THE ATOM WHOSE ATOMINDEX IS N
;;; 100000,,N LISTIFY THE LAST N ITEMS, TO CREATE A NEW ITEM
;;; 200000,,N MAKE A DOTTED LIST OUT OF THE LAST N+1 ITEMS
;;; 300000,,0 MERELY EVALUATE THE TOP THING ON THE STACK
;;; 7XXXXD,,INS TERMINATE, D IS INFORMATION DIGIT, INS MAY BE
;;; THE LH OF THE INSTRUCTION FOR A TYPE 5 WORD
;;; LISTOUT DOES NOT GENERATE THE TERMINATION WORD
(defun LISTOUT (x)
(let* ((type (typep x))
(index (if (not (memq type '#.useratoms-non-types))
(useratoms-lookup x))))
(cond ((not (null index)) (faslout index))
((eq type 'RANDOM)
(barf *LOC |Relative location of QUOTE randomness|))
((and (eq type 'LIST)
(or (eq (car x) SQUID)
(eq (car x) useratoms-intern-frob)))
(setq squidp 'T)
(listout (cadr x))
(and (eq (car x) SQUID) (faslout 3_33.)))
((EQ TYPE 'LIST)
(DO ((I 0 (1+ I)) (Y X (CDR Y)) (N 0))
((COND ((NULL Y)
(SETQ N 1_33.) ;FASL code to make up standard LIST
'T) ; terminating in the null list
((OR (NOT (PAIRP Y)) (EQ (CAR Y) SQUID))
(LISTOUT Y) ;Output the non-() list terminator
(SETQ N 2_33.) ; and signal FASL code for
'T)) ; non-standard list.
(FASLOUT (BOOLE 7 I N))) ;<typ-cod>_15.,,<length>
(LISTOUT (CAR Y))))
((HUNKP X)
(DO ((I 1 (1+ I)) (N (HUNKSIZE X)))
((NOT (< I N))
(LISTOUT (CXR 0 X))
(FASLOUT (BOOLE 7 4_33. N)))
(LISTOUT (CXR I X))))
('T (FASLOUT (ATOMINDEX X TYPE))) )))
;;; BUFFERBIN TAKES TWO ARGUMENTS: A NUMBER, WHICH IS THE
;;; RELOCATION TYPE, AND SOME OBJECT. THE FORMAT OF THIS SECOND
;;; OBJECT DEPENDS ON THE TYPE, AS FOLLOWS:
;;; # TYPE FORMAT OF SECOND AND THIRD OBJECTS
;;; 0 ABSOLUTE <FIXNUM>
;;; 1 RELOCATABLE <FIXNUM>
;;; 2 SPECIAL <FIXNUM>
;;; 3 SMASHABLE CALL <FIXNUM>
;;; 4 QUOTED ATOM <FIXNUM> ATOM
;;; 5 QUOTED LIST <FIXNUM> <LIST>
;;; 6 GLOBALSYM <FIXNUM>
;;; 7 GETDDTSYM <SQUOZE-VAL> <() OR FIXNUM>
;;; 8 ARRAY REFERENCE <ATOMINDEX>
;;; 9 [UNUSED]
;;; 10. ATOMINDEX INFO 0 <ATOM>
;;; 11. ENTRY INFO ARGSINFO (<NAME> . <TYPE>)
;;; 12. LOC <FIXNUM>
;;; 13. PUTDDTSYM 0 <ATOM>
;;; 14. EVAL MUNGEABLE <-N,,0> <RANDOM-SEXP>
;;; 15. END OF BINARY [IGNORED - IN PRACTICE () IS USED]
(DEFUN BUFFERBIN (TYP N X)
(DECLARE (FIXNUM TYP))
(STORE (BTAR BINCT) TYP)
(STORE (BXAR BINCT) N)
(STORE (BSAR BINCT) X)
(COND ((AND (NOT (= TYP 17)) (< BINCT 8.)) (SETQ BINCT (1+ BINCT)))
(T (DO ((N 0 (BOOLE 7 (LSH N 4) (BTAR I))) ;PACK 9 TYPE BYTES INTO
(I 0 (1+ I))) ;ONE WORD
((> I BINCT) (FASLOUT (LSH N (* 4 (- 8. BINCT))))))
(DO I 0 (1+ I) (> I BINCT)
(SETQ TYP (BTAR I) N (BXAR I))
(COND ((OR (< TYP 5) (= TYP 6) (= TYP 8.)) (FASLOUT N))
(T (SETQ X (BSAR I))
(COND ((= TYP 5)
(SETQ SQUIDP ())
(LISTOUT X)
(FASLOUT (BOOLE 7 -1_18. (LSH N -18.)))
(FASLOUT (COND (SQUIDP 0) ((SXHASH X)))))
((= TYP 10.)
(LET ((TYPE (TYPEP X)))
(COND ((EQ TYPE 'SYMBOL)
(SETQ X (PNGET X 7))
(FASLOUT (LENGTH X))
(MAPC 'FASLOUT X))
((EQ TYPE 'BIGNUM)
(FASLOUT (BOOLE 7 3_33.
(COND ((MINUSP X) 7_18.)
(0))
(LENGTH (CDR X))))
(MAPC 'FASLOUT (REVERSE (CDR X))))
((MEMQ TYPE '(FIXNUM FLONUM))
(FASLOUT (COND ((EQ TYPE 'FIXNUM) 1_33.)
(2_33.)))
(FASLOUT (LSH X 0)))
(T (BARF (LIST TYP N type X)
| - BUFFERBIN screw type 10|)))))
((= TYP 11.)
(FASLOUT (LOGIOR (LSH (ATOMINDEX (CAR X) 'SYMBOL)
18.)
(ATOMINDEX (CDR X) 'SYMBOL)))
(FASLOUT N))
((= TYP 14.) (LISTOUT X) (FASLOUT N))
((= TYP 15.) (FASLOUT #.(car (pnget '|*FASL+| 6))))
((= TYP 7) (FASLOUT N) (AND X (FASLOUT X)))
((= TYP 13.) (FASLOUT (SQOZ/| (LIST X))))
(T (BARF (LIST TYP N X) | - BUFFERBIN screw|))))))
(SETQ BINCT 0))))
(DEFUN POPNCK@ MACRO (L)
(SUBST (CADR L)
'tag
'(COND ((NULL (SETQ L (CDR L))) (GO DONE))
((EQ (CAR L) '/@) (SETQ WRD (BOOLE 7 WRD 20_18.)) (GO tag)))))
(DEFUN MKEVAL MACRO (L)
(SUBST (CADR L)
'n
'(PROG2 (SETQ FSLFLD n)
(AND (EQ (SETQ SYM (FASLEVAL (CAR L))) 'FOO) (GO MKWERR))
(SETQ TYPE (TYPEP SYM)))))
(DEFUN MAKEWORD (L)
(DECLARE (FIXNUM WRD NN II REL LN))
(PROG (WRD NN SYM TYPE OPGL ACGL ADDRGL INDXGL NOGL REL SYL OL)
(SETQ NOGL T REL 0 WRD 0 OL L)
(COND ((EQ (CAR L) 'SQUOZE)
(BINOUT (SQOZ/| (CDR L)))
(SETQ *LOC (1+ *LOC))
(RETURN ()))
((EQ (CAR L) 'BLOCK)
(SETQ TYPE (TYPEP (SETQ SYM (CADR L))))
(AND (EQ TYPE 'SYMBOL) (SETQ TYPE (TYPEP (SETQ SYM (GET SYM 'SYM)))))
(AND (NOT (EQ TYPE 'FIXNUM)) (GO MKWERR))
(DO II SYM (1- II) (ZEROP II) (BINOUT 0))
(SETQ *LOC (+ *LOC SYM))
(RETURN ()))
((COND ((EQ (CAR L) 'ASCII) (SETQ NN 7) T)
((EQ (CAR L) 'SIXBIT) (SETQ NN '6) T))
(MAPC 'BINOUT (SETQ SYM (PNGET (CADR L) NN)))
#%(LET ((LN (LENGTH SYM)))
(COND ((NOT (ZEROP (SETQ NN (- (BLOBLENGTH L) LN))))
(BINOUT 0)
(AND (NOT (= 1 NN))
(BARF L |How Much ASCII? - MAKEWORD|))
(SETQ LN (+ NN LN))))
(SETQ *LOC (+ *LOC LN)))
(RETURN ())))
(MKEVAL 3)
(COND ((MEMQ TYPE '(FIXNUM FLONUM)) (SETQ WRD SYM))
((NOT (EQ TYPE 'LIST)) (GO MKWERR))
((EQ (CAR SYM) 'RELOC)
(SETQ REL 1 WRD (CADR SYM))
(AND (SETQ OPGL (CDDR SYM)) (SETQ NOGL ())))
((NUMBERP (CAR SYM)) (SETQ NOGL () OPGL (CDR SYM) WRD (CAR SYM)))
(T (GO MKWERR)))
A (POPNCK@ A)
(MKEVAL 2)
(COND ((EQ TYPE 'FIXNUM) (SETQ WRD (+ WRD (ROT (BOOLE 1 SYM 17) -13.))))
((NOT (EQ TYPE 'LIST)) (GO MKWERR))
((NUMBERP (CAR SYM))
(SETQ NOGL () ACGL (CDR SYM))
(SETQ WRD (BOOLE 7 WRD (ROT (BOOLE 1 (CAR SYM) 17) -13.))))
(T (GO MKWERR)))
B (POPNCK@ B)
(MKEVAL 1)
(COND ((EQ TYPE 'FIXNUM) (SETQ NN SYM))
((NOT (EQ TYPE 'LIST)) (GO MKWERR))
((NUMBERP (CAR SYM)) (SETQ NOGL () ADDRGL (CDR SYM) NN (CAR SYM)))
((PROG2 (SETQ SYL (CADR SYM)) (MEMQ (CAR SYM) '(QUOTE FUNCTION)))
(SETQ REL (COND ((OR (EQ (SETQ TYPE (TYPEP SYL)) 'LIST)
(HUNKP SYL))
(SETQ ADDRGL SYL NN 0)
5)
('T (SETQ NN (ATOMINDEX SYL TYPE))
4))))
((COND ((EQ (CAR SYM) 'SPECIAL) (SETQ REL 2) T)
((EQ (CAR SYM) 'ARRAY) (SETQ REL 10) T))
(AND (NOT (SYMBOLP SYL)) (GO MKWERR))
(SETQ NN (ATOMINDEX SYL 'SYMBOL)))
((EQ (CAR SYM) 'RELOC)
(SETQ REL 1 NN (CADR SYM))
(AND (SETQ ADDRGL (CDDR SYM)) (SETQ NOGL ())))
((COND ((EQ (CAR SYM) 'EVAL)
(SETQ ADDRGL (CONS SQUID (CDR SYM)))
T)
((EQ (CAR SYM) SQUID) (SETQ ADDRGL SYM) T))
(SETQ REL 5))
(T (GO MKWERR)))
(SETQ WRD (BOOLE 7 (BOOLE 1 WRD -1_18.) (BOOLE 1 (+ WRD NN) 777777)))
C (POPNCK@ C)
(MKEVAL 0)
(COND ((MEMQ TYPE '(FIXNUM FLONUM)) (SETQ WRD (+ WRD (ROT SYM 18.))))
((NOT (EQ TYPE 'LIST)) (GO MKWERR))
((NUMBERP (CAR SYM))
(SETQ NOGL () INDXGL (CDR SYM) WRD (+ WRD (ROT (CAR SYM) 18.))))
(T (GO MKWERR)))
DONE (AND (= REL 4) (MEMQ (CAR OL) '(CALL JCALL NCALL NJCALL)) (SETQ REL 3))
(SETQ *LOC (1+ *LOC))
(BUFFERBIN REL WRD (AND (= REL 5) (PROG2 () ADDRGL (SETQ ADDRGL ()))))
(COND ((NOT NOGL)
(AND OPGL (GLHAK OPGL 3))
(AND ACGL (GLHAK ACGL 2))
(AND ADDRGL (GLHAK ADDRGL 1) (GO MKWERR))
(AND INDXGL (GLHAK INDXGL 0))))
(RETURN ())
MKWERR (PDERR OL |- Ill-formed expression - MAKEWORD|)
(ERR 'FASLAP)))
(DEFUN GLHAK (GLITCH FIELD)
(DECLARE (FIXNUM FIELD))
(COND ((NULL (CAAR GLITCH))
(COND ((NOT (= FIELD 1))) ;RETURNS "true" IF LOSES
(T (BUFFERBIN 6
(BOOLE 7 (COND ((CDDAR GLITCH) -4_33.) (0))
(BOOLE 1 (CADAR GLITCH) 777777))
())
(AND (CDR GLITCH) (GLHAK (CDR GLITCH) FIELD)))))
(T (BUFFERBIN 7
(BOOLE 7 (COND ((CDDAR GLITCH) -4_33.) (0)) ;PLUS OR MINUS?
(COND ((CADAR GLITCH) 2_33.) (0)) ;VALUE KNOWN AT ASSEMBLY TIME?
(ROT FIELD -4) ;FIELD NUMBER
(CAAR GLITCH)) ;SQUOZE REPRESENTATION
(CADAR GLITCH)) ;GUESS AT SYMVAL
(AND (CDR GLITCH) (GLHAK (CDR GLITCH) FIELD)))))
(DEFUN BINOUT (X) (BUFFERBIN 0 X ()))
(DEFUN *DDTSYM (SYM) (FASLDEFSYM SYM (LIST '0 (LIST (SQOZ/| (LIST SYM)) (GETDDTSYM SYM)))))
(DEFUN FASLOUT (X) (OUT IMOSAR X))

838
src/comlap/initia.120 Executable file
View File

@@ -0,0 +1,838 @@
;;; INITIA -*-LISP-*-
;;; **************************************************************
;;; ***** MACLISP ***** (Initialization for COMPLR) *************
;;; **************************************************************
;;; ** (C) Copyright 1981 Massachusetts Institute of Technology **
;;; ****** This is a Read-Only file! (All writes reserved) *******
;;; **************************************************************
(SETQ INITIAVERNO '#.(let* ((file (caddr (truename infile)))
(x (readlist (exploden file))))
(setq |verno| (cond ((fixp x) file) ('/120)))))
(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) (COMPDECLARE) (FASLDECLARE) (GENPREFIX |/|in|) )
(EVAL-WHEN (EVAL) (SETQ CAR 'T))
(AND (NOT (STATUS FEATURE SAIL))
(MAPC '(LAMBDA (X)
(LET (((TYPE FUN . L) X) (PROP))
(SETQ PROP (GET FUN TYPE))
(MAPC '(LAMBDA (X) (AND (NOT (GET X TYPE))
(PUTPROP X PROP TYPE)))
L)))
'((FSUBR UREAD EREAD) (LSUBR OPEN EOPEN) (SUBR LOAD ELOAD))))
(COMMENT INITIALIZING FUNCTIONS)
(DEFUN INITIALIZE FEXPR (L)
(SSTATUS FEATURE COMPLR)
(SSTATUS FEATURE NCOMPLR)
(SETQ OPSYS (STATUS FILESYSTEM-TYPE)) ;I REALLY INTENDED THIS TO BE
(setq LINEMODEP (or (eq opsys 'DEC10) ; "FILESYSTEM-TYPE", BUT ...
(and (eq opsys 'DEC20)
(eq (status OPSYSTEM-TYPE) 'TOPS-20))))
(AND (EQ OPSYS 'DEC10)
(EQ (STATUS OPSYSTEM-TYPE) 'SAIL)
(SETQ OPSYS 'SAIL))
(SETQ MAKLAP-DEFAULTF-STYLE 'MIDAS)
(SETQ OBARRAY (SETQ SOBARRAY (GET 'OBARRAY 'ARRAY)))
(SETQ READTABLE (SETQ SREADTABLE (GET 'READTABLE 'ARRAY)))
(SETQ SWITCHTABLE ;Setup before INTERNing
(APPEND '(
(/$ FLOSW () ) (/+ FIXSW () ) (/~ QUIT-ON-ERROR () )
(/2 HUNK2-TO-CONS ()) (/7 USE-STRT7 ())
(A ASSEMBLE () ) (C CLOSED () )
(D DISOWNED () ) (E EXPR-HASH () )
(F FASL #.(AND (MEMQ COMPILER-STATE '(MAKLAP DECLARE)) T))
(G GAG-ERRBREAKS () ) (H EXPAND-OUT-MACROS T)
(I INITIALIZE () )
(K NOLAP #.(AND (MEMQ COMPILER-STATE '(MAKLAP DECLARE)) T))
(M MACROS () ) (O ARRAYOPEN T)
(R RUNTIME-LIMITP () ) (S SPECIALS () )
(T TTYNOTES #.(AND (NOT (MEMQ COMPILER-STATE
'(MAKLAP DECLARE))) T))
(W MUZZLED () ) (X MAPEX () )
(Y YESWARNTTY #.(AND (NOT (MEMQ COMPILER-STATE
'(MAKLAP DECLARE))) T) )
(Z SYMBOLS () )
)
()))
(PUSH (COND (#%(SAILP)
(SETQ MAKLAP-DEFAULTF-STYLE () )
'(U UNFASLCOMMENTS () ))
( '(U UNFASLCOMMENTS T)))
SWITCHTABLE)
(DO I 65. (1+ I) (> I 90.)
(AND (NOT (ASSQ (ASCII I) SWITCHTABLE))
(PUSH (LIST (ASCII I)
(IMPLODE (APPEND '(S W I T C H /-) (LIST (ASCII I))))
() )
SWITCHTABLE)))
(COND ((STATUS FEATURE NO-EXTRA-OBARRAY)
(SETQ CREADTABLE READTABLE COBARRAY OBARRAY))
('T (SETQ CREADTABLE (ARRAY
()
READTABLE
(COND ((AND (BOUNDP 'IREADTABLE)
(EQ (TYPEP IREADTABLE) 'ARRAY)
(EQ (CAR (ARRAYDIMS IREADTABLE))
'READTABLE))
IREADTABLE)
('T))))
;;Glaag, patch up for the /#-MACRO-DATALIST thing!
#%(let ((y (get 'SHARPM 'VERSION)))
(cond ((null y) (+internal-lossage 'SHARPM 'INITIALIZE () ))
((alphalessp y "82"))
(T (push #%(let ((x (assoc READTABLE /#-MACRO-DATALIST)))
(cons CREADTABLE (cdr x)))
/#-MACRO-DATALIST))))
(SETQ COBARRAY (ARRAY
()
OBARRAY
(COND ((AND (BOUNDP 'IOBARRAY)
(EQ (TYPEP IOBARRAY) 'ARRAY)
(EQ (CAR (ARRAYDIMS IOBARRAY))
'OBARRAY))
IOBARRAY)
((GET 'OBARRAY 'ARRAY)))))
(LET ((OBARRAY COBARRAY) (READTABLE CREADTABLE))
(MAPC '(LAMBDA (X)
(COND ((NOT (EQ X (INTERN X)))
(REMOB X)
(INTERN X))))
(STATUS FEATURES))
(MAPC '(LAMBDA (X) (INTERN (CADR X))) SWITCHTABLE)
(MAPC 'INTERN SAIL-MORE-SYSFUNS)
; (AND #%(SAILP) (SETSYNTAX '/" 'MACRO '%%%STRING%%%) )
)))
(SETSYNTAX '/~ 'MACRO 'MACR-AMP-FUN)
; (AND #%(SAILP) (SETSYNTAX '/" 'MACRO '%%%STRING%%%))
#%(LET ((PROP (LSUB '(MACRO SPECIAL ARGS *EXPR *FEXPR *LEXPR
NUMVAR NUMFUN *ARRAY OHOME SKIP-WARNING)
L))
(Z () )
(TMP () ) )
(MAPATOMS '(LAMBDA (Y)
(SETQ TMP (ASSQ Y CCLOAD:INITIAL-PROPS))
(LREMPROP Y (LSUB PROP (CDR TMP))) ;Remove compilation
(COND ((SETQ DATA (GET Y 'FUNTYP-INFO)) ;properties.
(COND ((ARGS Y))
((GET Y (CAR DATA)) (ARGS Y (CDR DATA)))
((CDR DATA) (PUTPROP Y (CDR DATA) 'ARGS))))
((AND (NOT (SYSP Y)) (NULL TMP)) (ARGS Y () )))
(AND (BOUNDP Y) ;SPECIALize the
(NOT (MEMQ Y '(T NIL))) ;system varialbes
(SETQ DATA Y)
(MEMQ 'VALUE (STATUS SYSTEM DATA))
(PUSH Y Z))))
(APPLY 'SPECIAL Z)
;; (STATUS SYSTEM) doesn't win on following
(AND (BOUNDP '+INTERNAL-INTERRUPT-BOUND-VARIABLES)
(APPLY 'SPECIAL +INTERNAL-INTERRUPT-BOUND-VARIABLES))
(SPECIAL +INTERNAL-WITHOUT-INTERRUPTS)
(FASLINIT))
(PUTPROP '%HUNK1 '(() . 1) 'ARGS)
(PUTPROP '%HUNK2 '(() . 2) 'ARGS)
(PUTPROP '%HUNK3 '(() . 3) 'ARGS)
(PUTPROP '%HUNK4 '(() . 4) 'ARGS)
(SETQ PRINLEVEL (SETQ PRINLENGTH (SETQ *RSET () )))
(SETQ BASE 8. IBASE 8. *NOPOINT 'T RUNTIME-LIMIT 600.0E6)
(SETQ MACRO-EXPANSION-USE () )
(SETQ COMPILATION-FLAGCONVERSION-TABLE
'((EXPR . SUBR) (FEXPR . FSUBR) (LEXPR . LSUBR)))
(SETQ SPECVARS () GENPREFIX '(/| G) GFYC 0 P1GFY ()
CLOSED () FIXSW () FLOSW () MACROLIST ()
GAG-ERRBREAKS () RNL () CFVFL ()
UNDFUNS () P1LLCEK () LAPLL () ROSENCEK ()
FASLPUSH () RECOMPL () CMSGFILES () LAP-INSIGNIF 'T
EOC-EVAL () COMPILER-STATE 'TOPLEVEL CHOMPHOOK ()
USERATOMS-HOOKS '(EXTSTR-USERATOMS-HOOK) USERATOMS-INTERN ()
TOPFN () ONMLS () READ () MSDEV 'DSK MSDIR ()
CL () CLEANUPSPL 0 FILESCLOSEP () IMOSAR ()
EOF-COMPILE-QUEUE () USER-STRING-MARK-IN-FASL T )
#%(SETUP-CATCH-PDL-COUNTS)
(MAPC '(LAMBDA (X) (SET (CADR X) (CADDR X))) SWITCHTABLE)
(MAPC '(LAMBDA (X) (SET X (COPYSYMBOL X () )))
'(PROGN GOFOO NULFU COMP CARCDR ARGLOC SQUID MAKUNBOUND IDENTITY
USERATOMS-INTERN-FROB))
(PUTPROP SQUID '(LAMBDA (GL) (LIST 'QUOTE GL)) 'MACRO)
(SETQ QSM (LIST (LIST 'QUOTE (LIST SQUID MAKUNBOUND))))
(SETQ STSL (LIST (DELQ 'TERPR (STATUS STATUS))
(DELQ 'TERPR (STATUS SSTATUS))))
(SETQ ARGLOC (LIST ARGLOC) CLPROGN (LIST PROGN))
(SETQ CAAGL (LIST (LIST (CONS MAKUNBOUND ARGLOC) 1)
(LIST (CONS MAKUNBOUND ARGLOC) 2)))
(SETQ MAPSB (NCONC (MAPCAR 'LIST '(VL EXIT EXITN PVR STSL))
(LIST (CONS 'GOFOO GOFOO))))
(SETQ COMAL (SUBST '() 'NIL '((NIL . NIL) (FIXNUM . FIXNUM) (FLONUM . FLONUM) (T))) )
(RPLACD (CAR COMAL) (CAR COMAL)) ;Sets up infinite
(RPLACD (CADR COMAL) (CADR COMAL)) ; type lists for COMARITH
(RPLACD (CADDR COMAL) (CADDR COMAL))
(FIXNUM BASE IBASE BPORG BPEND TTY) ;Some known declarations
(FIXNUM (LENGTH) (RANDOM) (EXAMINE FIXNUM) (LISTEN) (RUNTIME)
(GETCHARN NOTYPE FIXNUM) (FLATSIZE) (FLATC) (IFIX)
(^ FIXNUM FIXNUM) (\\ FIXNUM FIXNUM) (LSH) (ROT) (ASH)
(SXHASH) (TYIPEEK) (TYI) (HAULONG) (HUNKSIZE)
(+INTERNAL-CHAR-N () FIXNUM)
(+INTERNAL-STRING-WORD-N () FIXNUM)
(LDB FIXNUM FIXNUM) (DPB FIXNUM FIXNUM)
(*LDB FIXNUM FIXNUM) (*DPB FIXNUM FIXNUM)
(LOAD-BYTE FIXNUM FIXNUM FIXNUM)
(DEPOSIT-BYTE FIXNUM FIXNUM FIXNUM FIXNUM)
(*LOAD-BYTE FIXNUM FIXNUM FIXNUM)
(*DEPOSIT-BYTE FIXNUM FIXNUM FIXNUM FIXNUM) )
(FIXNUM (IN) (LINEL) (PAGEL) (CHARPOS) (LINENUM) (PAGENUM) (LENGTHF))
(PUTPROP 'BOOLE (CONS (CADR COMAL) (CONS 'FIXNUM (CADR COMAL))) 'NUMFUN)
(PUTPROP IDENTITY 'T 'NUMBERP)
(PUTPROP 'FIXNUM-IDENTITY `(,IDENTITY FIXNUM) 'ARITHP)
(PUTPROP 'FLONUM-IDENTITY `(,IDENTITY FLONUM) 'ARITHP)
(FLONUM (SIN) (COS) (SQRT) (LOG) (EXP) (ATAN) (TIME)
(^$ FLONUM FIXNUM) (FSC) (FLOAT))
(NOTYPE (GETCHAR NOTYPE FIXNUM) (CXR FIXNUM) (DEPOSIT FIXNUM))
(ARRAY* (NOTYPE OBARRAY 1 READTABLE 1))
(PUTPROP PROGN 'T '*LEXPR)
(COND (#%(SAILP)
(MAPC '(LAMBDA (X) (PUTPROP X 'T 'SKIP-WARNING))
'(PUSH POP LET))
(SSTATUS TTYINT 200. (STATUS TTYINT 194.))
(SSTATUS TTYINT 467. 'S-C)
(MAPC #'(LAMBDA (X)
(OR (GET X 'MACRO)
(PUTPROP X
(INTERN (PNAMECONC X '| | 'MACRO))
'MACRO)))
'(LET! MACRODEF MATCH-MACRO TRANS TRANSDEF))))
(SSTATUS TTYINT '/ 'INT-^^-FUN)
(SSTATUS TTYINT '/ 'INT-^^-FUN)
(SSTATUS TTYINT '/ 'DEBUG-BREAK)
(SETQ OBARRAY #.(COND ((MEMQ COMPILER-STATE '(MAKLAP DECLARE)) 'COBARRAY)
('SOBARRAY)))
(SETQ READTABLE #.(COND ((MEMQ COMPILER-STATE '(MAKLAP DECLARE)) 'CREADTABLE)
('SREADTABLE)))
(setq error-break-environment (cons cobarray creadtable))
(GCTWA))
(DEFUN DEBUG-BREAK N N
(NOINTERRUPT () )
(MSOUT-BRK ARGS SOBARRAY SREADTABLE 'SOBARRAY-ENVIRONMENT))
;;; Function for ~ macro char
(DEFUN MACR-AMP-FUN ()
((LAMBDA (OBARRAY READTABLE)
(COND ((= (TYIPEEK) #.(INVERSE-ASCII '/~))
(TYI)
(SETQ OBARRAY SOBARRAY READTABLE SREADTABLE)))
(READ))
COBARRAY CREADTABLE))
;;; Function for control-^ interrupt
(DEFUN INT-^^-FUN N
(SETQ SAVED-ERRLIST ERRLIST ERRLIST () N (ARG 2))
(SSTATUS TOPLEVEL '(INT-^^-TOPLE))
(DO () ((OR (= (LISTEN) 0) (= (TYI) N))))
(^G))
(DEFUN INT-^^-TOPLE () ;Starts up MAKLAP from ^^
#%(ERL-SET)
(SSTATUS TOPLEVEL () )
(setq LINEMODEP (or (eq opsys 'DEC10)
(and (eq opsys 'DEC20)
(eq (status OPSYSTEM-TYPE) 'TOPS-20))))
(COMPLRVERNO)
(NOINTERRUPT () )
(cond ((not LINEMODEP) (maklap))
((unwind-protect (prog2 (sstatus LINMO T) (MAKLAP))
(sstatus LINMO ())))))
(DEFUN DB FEXPR (L) ;Setup for debugging
L
(SETQ SAVED-ERRLIST ERRLIST ERRLIST () )
(SSTATUS TOPLEVEL '(DB-TOPLE))
(^G))
(DEFUN DB-TOPLE ()
(SSTATUS UUOLI)
#%(ERL-SET)
(*RSET (NOUUO 'T))
(SETQ OBARRAY SOBARRAY READTABLE SREADTABLE)
(SETQ ^W (SETQ ^R () ))
(setq LINEMODEP ())
(sstatus LINMO ())
(SETQ ERRSET (FUNCTION (LAMBDA (X) X (BREAK ERRSET))))
(PROG (L)
A (COND ((NOT (GET 'BS 'FSUBR))
(COND (#%(ITSP) (SETQ L '((DSK LIBLSP) BS FASL)))
((PROBEF (SETQ L '((DSK) BS FASL))))
('T (TERPRI)
(PRINC '|Please load BS FASL!|)
(BREAK LOAD)
(GO A)))
(ELOAD L))))
(SSTATUS TOPLEVEL () ))
(DEFUN S-C (() ()) (CDUMP '|SAVE COMPLR|))
;This function never returns, but is a way to start up the toplevel complr
(DEFUN CDUMP N
(SETQ ERRLIST () SAVED-ERRLIST '((COMPLRVERNO)))
(SSTATUS TOPLEVEL '(COMPLR-TOPLE))
(SETQ CDUMP (LISTIFY N))
(OR (GET 'COMPLR 'VERSION)
(PUTPROP 'COMPLR COMPLRVERNO 'VERSION))
(*THROW () ())
;;(COMMENT Hopefully, this goes to a TOPLEVEL user of COMPLR-TOPLE)
)
(DEFUN COMPLR-TOPLE () ;Initial TOPLEVEL loop
(SETQ OBARRAY COBARRAY READTABLE CREADTABLE)
(SSTATUS TOPLEVEL () )
(SETQ - () + () )
#%(ERL-SET)
(SSTATUS NOFEATURE NOLDMSG)
(GCTWA 1)
(GC)
(APPLY (COND ((STATUS FEATURE SHARABLE)
(AND (NULL (CDR CDUMP)) (PUSH () CDUMP))
'PURE-SUSPEND)
('SUSPEND))
CDUMP)
(COMPLR-TOPLE-AFTER-SUSPEND))
(DEFUN COMPLR-TOPLE-AFTER-SUSPEND ()
;; This function is an entry-point which some systems
;; depend on. e.g. the macsyma-source-compiler. -gjc
(SSTATUS GCTIM 0)
(setq LINEMODEP (or (eq opsys 'DEC10)
(and (eq opsys 'DEC20)
(eq (status OPSYSTEM-TYPE) 'TOPS-20))))
#%(LET ((UID (STATUS USERID))
(USN (COND ((STATUS STATUS HOMED) (STATUS HOMED)) ((STATUS UDIR))))
(MSGFILES '(T))
(COMPILER-STATE 'DECLARE)
FIX-FILE FILE OFILE DEFAULTF-DEVICE)
(SETQ DEFAULTF-DEVICE (CASEQ OPSYS
(ITS '(DSK LSPDMP))
(DEC20 '(PS MACLISP))
(SAIL '(DSK (MAC LSP)))
(T '(LISP)))
DEFAULTF `(,defaultf-device * ,(caseq opsys
(ITS '>)
(SAIL '|___|)
(T 'LSP)))
FIX-FILE `(,defaultf-device CLFIX ,(get 'COMPLR 'VERSION)))
(SETQ DEFAULTF-DEVICE
`((,(car defaultf-device) ,(status UDIR)) ,.(cdr defaultf))
)
(COND ((STATUS FEATURE SHARABLE)
(ANNOUNCE-&-LOAD-INIT-FILE 'COMPLR () FIX-FILE))
('T (COMPLRVERNO)
(TERPRI)
(COND ((SETQ FIX-FILE (PROBEF FIX-FILE))
(TERPRI)
(PRINC '|Loading fix-up file |)
(PRIN1 (NAMESTRING FIX-FILE))
(COND ((ATOM (ERRSET (LOAD FIX-FILE)))
(PRINC '| *** Errors in Fix File ***|)
(BREAK FIX)))))
(SETQ OFILE `((,(cond (#%(dec20p) 'PS) ('DSK)) ,usn)
,.(cond (#%(itsp) `(,uid COMPLR))
('T `(COMPLR INI))))
FILE (PROBEF OFILE)
DEFAULTF DEFAULTF-DEVICE)
(COND ((COND (FILE)
(#%(ITSP)
(RPLACA (CDR OFILE) '*)
(AND (SETQ FILE (CAR (ERRSET (EOPEN OFILE '(NODEFAULT))
() )))
(SETQ FILE (TRUENAME FILE)))
FILE))
(TERPRI) (TERPRI)
(PRINC '|Loading "|)
(PRINC (NAMESTRING FILE))
(PRINC '|", COMPLR initialization file for |)
(PRINC (COND ((OR (EQ (CADR OFILE) '*) (NOT #%(ITSP))) USN)
(UID)))
(TERPRI)
(AND (ATOM (ERRSET (ELOAD FILE) 'T))
(PRINC '| *** Errors during loading *** BEWARE!| TYO)))) ))
(COND ((SETQ DATA (STATUS JCL))
(LET (WINP (JCL-LINE DATA) RUNP)
(SETQ WINP (ERRSET
(PROG (M L LL)
(SETQ L DATA)
A (AND (< (SETQ M (GETCHARN (CAR L) 1)) 27.)
;Flush control chars
(NOT (= M 17.)) ;[except ^Q] from
(SETQ L (CDR L)) ;front of JCL list
(GO A))
(SETQ LL () )
B (SETQ M (GETCHARN (CAR L) 1))
(PUSH (COND ((AND (< M 123.) (> M 96.))
(- M 32.)) ;Uppercaseify
(M)) ; rest of line
LL)
(AND (SETQ L (CDR L)) (GO B))
C (AND (< (CAR LL) 27.) ;Flush control
(SETQ LL (CDR LL)) ; chars from
(GO C)) ; end of line
(SETQ LL (NREVERSE LL))
(cond ((not (eq (status OPSYSTEM-TYPE) 'ITS))
(cond ((and (= (car ll) #/R)
(cdr ll)
(= (cadr ll) #/U)
(cddr ll)
(= (caddr ll) #/N)
(cdddr ll)
(= (cadddr ll) #\SPACE))
(setq ll (nthcdr 4 ll)
runp 'T)))
(prog (x n)
(declare (fixnum n))
(setq n (if runp #/; #\SPACE))
;Flush subsystem name -- e.g. COMPLR
A (and (null ll) (return () ))
(pop ll x)
(if (not (= x n)) (go A))
;Flush leading spaces
B (cond ((null ll))
((= (car ll) #\SPACE)
(pop ll)
(go B))))))
(cond ((not LINEMODEP) (APPLY 'MAKLAP ll))
((unwind-protect
(prog2 (sstatus linmo T)
(APPLY 'MAKLAP ll))
(sstatus linmo () )))))
'T ))
(COND ((ATOM WINP)
(COND (WINP (PRINC '| *** Errors from JCL command *** /î;JCL = /"|)
(PRINC (MAKNAM JCL-LINE))
(PRINC '/"/î )
(BREAK JCL))
('T (PRINC '| *** Errors (probably I/O) in COMPLR Toplevel|)
(do ((l '((INFILE . INPUT) (IMOSAR . FASL)) (cdr l))
(x))
((null l))
(setq x (symeval (caar l)))
(and (filep x)
(memq 'FILEPOS (cdr (status FILEM x)))
(princ `(,(filepos x) = CURRENT ,(cdar l) FILEPOS))))
(BREAK COMPLR-TOPLE))) ))
(INT-^^-TOPLE)))
('T (cond ((not LINEMODEP) (maklap))
((unwind-protect (prog2 (sstatus linmo T) (MAKLAP))
(sstatus linmo ()))))))) )
;;; NOTE: THE LIST OF GLOBALSYMS SHOULD CORRESPOND TO
;;; THE LIST OF SYMBOLS AT LOCATION LSYMS IN LISP.
(DEFUN FASLINIT ()
(GETMIDASOP ())
(LET ((OBARRAY OBARRAY) (FL)
(PROPS '(SYM ATOMINDEX ARGSINFO ENTRY GLOBALSYM))
(ACS '(FOO A B C AR1 AR2A T TT D R F FOO P FLP FXP SP)))
(MAPATOMS '(LAMBDA (X) (LREMPROP X PROPS)))
(SETQ LDFNM (FASLAPSETUP/| () )) ;Sets up GLOBALSYMS
(COND ((AND (BOUNDP 'COBARRAY)
(EQ (TYPEP COBARRAY) 'ARRAY)
(SETQ FL (ARRAYDIMS COBARRAY))
(EQ (CAR FL) 'OBARRAY)
(NOT (AND (BOUNDP 'SOBARRAY) (EQ SOBARRAY COBARRAY))))
(SETQ FL '(% @ BLOCK ASCII SIXBIT SQUOZE CALL NCALL JCALL NJCALL
ENTRY DEFSYM BLOCK SYMBOLS BEGIN DDTSYM
THIS IS THE UNFASL FOR LISP FILE COMPILED BY COMPILER))
(MAPATOMS '(LAMBDA (X) (AND (GETL X '(SYM GLOBALSYM)) (PUSH X FL))))
;;;AFTER THE FASLAPSETUP/|, ONLY SYMS SHOULD BE GLOBALSYMS. IN ORDER:
;*SET *MAP PRINTA SPECBIND UNBIND IOGBND *LCALL *UDT ARGLOC
;INUM ST FXNV1 PDLNMK PDLNKJ FIX1A FIX1 FLOAT1 IFIX IFLOAT
;FXCONS FLCONS ERSETUP ERUNDO GOBRK CARCDR *STORE NPUSH PA3
;MAKUNBOUND FLTSKP FXNV2 FXNV3 FXNV4 FIX2 FLOAT2 AREGET
;UINITA UTIN INTREL INHIBIT NOQUIT CHECKI 0PUSH 0*0PUSH
;NILPROPS VBIND %CXR %RPX
(SETQ OBARRAY COBARRAY)
(MAPC 'INTERN FL) ;Cross-interns GLOBALSYMS
(MAPC 'INTERN (APPEND PROPS ACS))) ;Plus a few other words
(T (SETQ COBARRAY OBARRAY CREADTABLE READTABLE)))
(SETQ SQUIDP ()) ;Lists and set up GLOBALSYMS
(DO ((I 0 (1+ I)) (L ACS (CDR L))) ;Now define SYMS for LISP acs
((NULL L))
(AND (NOT (EQ (CAR L) 'FOO)) (PUTPROP (CAR L) I 'SYM)))
(ARRAY LCA T 16.) (ARRAY NUMBERTABLE T 127.)
(ARRAY BTAR FIXNUM 9.) (ARRAY BXAR FIXNUM 9.) (ARRAY BSAR T 9.)
(DO I 0 (1+ I) (= I 16.) (STORE (LCA I) (CONS I '((() -1)))))
(SETQ IMOSAR () IMOUSR ())
(SSTATUS FEATURE FASLAP)
(GCTWA)))
(COMMENT FILL INITIAL ARRAYS)
(ARRAY AC-ADDRS T #.(+ (NUMVALAC) (NUMNACS) 1))
(ARRAY PDL-ADDRS T 3 #.(+ 1 (NPDL-ADDRS)))
(ARRAY STGET T #.(+ (NUMVALAC) (NUMNACS)))
(ARRAY BOLA T #.(+ (NACS) (NUMNACS) 1) 7)
(ARRAY CBA T 16.)
(ARRAY A1S1A T #.(NUMNACS) 4)
(ARRAY PVIA T 3 (1+ (MAX #.(MAX-NPUSH) #.(MAX-0PUSH) #.(MAX-0*0PUSH))))
(PROGN (DO CNT #.(+ (NUMVALAC) (NUMNACS)) (1- CNT) (< CNT 1) ;Sets AC-ADDRS
(STORE (AC-ADDRS CNT) CNT))
(DO CNT #.(NPDL-ADDRS) (1- CNT) (< CNT 1) ;Sets PDL-ADDRS
(STORE (PDL-ADDRS 0 CNT) (- CNT #.(NPDL-ADDRS)))
(STORE (PDL-ADDRS 1 CNT) (- (+ CNT #.(FXP0)) #.(NPDL-ADDRS)))
(STORE (PDL-ADDRS 2 CNT) (- (+ CNT #.(FLP0)) #.(NPDL-ADDRS))))
;;; (STGET n) is for accessing segment table into register n
(DO CNT #.(+ (NUMVALAC) (NUMNACS) -1) (1- CNT) (< CNT 1)
(STORE (STGET CNT) (SUBST CNT 'N '(0 ST N))))
(DO ((HLAC #.(+ (NACS) (NUMNACS)) (1- HLAC))
(ATPL `((TDZA N N)
(MOVEI N ,(if (eq *:truth 'T) ''T '*:truth))
(SKIPE 0 N)
(MOVNI #.(NUMVALAC) N)
(MOVEI N '() )
(SKIPN 0 N))))
((< HLAC 1))
(DO ((CNT 1 (1+ CNT)) (ATPL1 ATPL (CDR ATPL1)))
((NULL ATPL1))
(STORE (BOLA HLAC CNT) (SUBST HLAC 'N (CAR ATPL1)))))
(FILLARRAY 'CBA '((SETZ) (AND) (ANDCA) (SETA) ;Sets CBA
(ANDCM) (SETM) (XOR) (IOR) (ANDCB)
(EQV) (SETCM) (ORCA) (SETCA)
(ORCM) (ORCB) (SETO)))
(DO CNT #.(- (NUMNACS) 1) (1- CNT) (< CNT 0) ;Sets A1S1A
(DO ((HLAC 0 (1+ HLAC)) (L '((ADDI 1)
(SUBI 1)
(FADRI 66304.) ;66304. = 201400[8]
(FSBRI 66304.))
(CDR L)))
((NULL L))
(STORE (A1S1A CNT HLAC) (LIST (CAAR L)
(+ CNT #.(NUMVALAC))
(CADAR L)))))
;;; Makes up array of JSPs to places that push the appropriate number
;;; of pdl-variable initialization values, onto the appropriate stack.
;;; (PVIA 0 n) ==> (JSP T (NPUSH -n)) pushes ()s onto REGPDL
;;; (PVIA 1 n) ==> (JSP T (0PUSH -n)) pushes 0s onto FXPDL
;;; (PVIA 2 n) ==> (JSP T (0*0PUSH -n)) pushes 0.0s onto FLPDL
(STORE (PVIA 0 0) #.(MAX-NPUSH))
(STORE (PVIA 1 0) #.(MAX-0PUSH))
(STORE (PVIA 2 0) #.(MAX-0*0PUSH))
(STORE (PVIA 0 1) '(PUSH P (% 0 0 '())))
(STORE (PVIA 1 1) '(PUSH FXP (% 0)))
(STORE (PVIA 2 1) '(PUSH FLP (% 0.0)))
(STORE (PVIA 0 2) 'NPUSH)
(STORE (PVIA 1 2) '0PUSH)
(STORE (PVIA 2 2) '0*0PUSH)
(DO CNT 0 (1+ CNT) (> CNT 2)
(DO HLAC (PVIA CNT 0) (1- HLAC) (< HLAC 3)
(STORE (PVIA CNT HLAC) (LIST 'JSP 'T (LIST (PVIA CNT 2) (- HLAC))))))
(COND (*PURE
(MAPC '(LAMBDA (GL)
(SETQ GL (GET GL 'ARRAY))
(DO CNT (1- (CADR (ARRAYDIMS GL))) (1- CNT) (< CNT 0)
(STORE (ARRAYCALL T GL CNT)
(PURCOPY (ARRAYCALL T GL CNT)))))
'(AC-ADDRS STGET CBA))
(MAPC '(LAMBDA (GL)
(SETQ GL (GET GL 'ARRAY))
(DO CNT (1- (CADR (ARRAYDIMS GL))) (1- CNT) (< CNT 0)
(DO HLAC (1- (CADDR (ARRAYDIMS GL)))
(1- HLAC)
(< HLAC 0)
(STORE (ARRAYCALL T GL CNT HLAC)
(PURCOPY (ARRAYCALL T GL CNT HLAC))))))
'(PDL-ADDRS BOLA A1S1A PVIA))))
)
(COMMENT PUT PROPERTIES ON VARIOUS SYMBOLS)
(PROGN (DEFPROP RPLACD (HRRM . HRRM) INST)
(DEFPROP RPLACA (HRLM . HRLM) INST)
(DEFPROP RPLACD (HLLZS . HLLZS) INSTN)
(DEFPROP RPLACA (HRRZS . HRRZS) INSTN)
(DEFPROP SETPLIST (HRRM . HRRM) INST)
(DEFPROP SETPLIST (HLLZS . HLLZS) INSTN)
(DEFPROP A (HLRZ . HLRZ) INST)
(DEFPROP D (HRRZ . HRRZ) INST)
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'IMMED))
'(MOVE CAMN CAME
ADD SUB IMUL IDIV CAMLE CAMG CAML CAMGE MOVN
AND ORCB SETCM XOR EQV IOR ANDCB ANDCA ANDCM ORCM ORCA)
'(MOVEI CAIN CAIE
ADDI SUBI IMULI IDIVI CAILE CAIG CAIL CAIGE MOVNI
ANDI ORCBI SETCMI XORI EQVI IORI ANDCBI ANDCAI ANDCMI ORCMI ORCAI))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'JSP))
'(CONS XCONS NCONS %HUNK1 %HUNK2 %HUNK3 %HUNK4)
'(
(((JSP T %CONS) .
(JSP T %C2NS))
. ((JSP T %PDLC) .
(JSP T %C2NS)))
(((JSP T %XCONS) .
(JSP T %PDLXC))
. PUNT )
(((JSP T %NCONS)) .
((JSP T %PDLNC)))
((JSP T %HUNK1))
((JSP T %HUNK2))
((JSP T %HUNK3))
((JSP T %HUNK4))
))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'COMMU) (PUTPROP INSTN INST 'COMMU))
'(CONS *GREAT *PLUS *TIMES EQUAL CAMG CAMGE JUMPGE JUMPL)
'(XCONS *LESS *PLUS *TIMES EQUAL CAML CAMLE JUMPLE JUMPG))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'CONV) (PUTPROP INSTN INST 'CONV))
'(JUMP JUMPL JUMPE JUMPLE TRNN TLNN SOJE CAMG CAML
CAMN CAIG CAIL CAIE SKIPE SKIPG SKIPL)
'(JUMPA JUMPGE JUMPN JUMPG TRNE TLNE SOJN CAMLE CAMGE
CAME CAILE CAIGE CAIN SKIPN SKIPLE SKIPGE))
;A status option with no STATUS property means no evaluation of its
; entries. "(x . y)" means "x" is for sstatus and "y" for status;
; x and y are "A" to mean evaluate all but option name, and "B" to
; mean evaluate all but option name and next thing.
(MAPC '(LAMBDA (Z Y) (MAPC '(LAMBDA (X) (PUTPROP X Z 'STATUS)) Y))
'((A . A) (() . A) (A . () ) (B . B))
'((TTY TTYRE TTYTY TTYCO TTYSC TTYIN LINMO PDLMA INTER
GCMIN GCSIZ GCMAX)
(DIVOV FTVSI + TOPLE UUOLI ABBRE GCTIM GCWHO WHO1 WHO2 WHO3
EVALH BREAK MAR CLI FLUSH PUNT RANDO /_ LOSEF)
(SYSTE SPCSI PURSI PDLSI PDLRO FILEM TTYSI OSPEE HSNAM)
(MACRO SYNTA CHTRA)))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'MINUS))
'(MOVEI ADDI SUBI)
'(MOVNI SUBI ADDI))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'BOTH))
'(ADD SUB IMUL IDIV FADR FSBR FDVR FMPR)
'(ADDB SUBB IMULB IDIVB FADRB FSBRB FDVRB FMPRB))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'FLOATI))
'(FADR FSBR FMPR FDVR MOVE)
'(FADRI FSBRI FMPRI FDVRI MOVSI))
((LAMBDA (Y)
(MAPC '(LAMBDA (X)
(COND ((GET (CAR X) 'AUTOLOAD)
(COND ((NULL (CDDR X)))
((EQUAL (SETQ Y (ARGS (CAR X))) (CDDR X)))
(T (AND Y (ERROR '|ARGS data doesn't match|
X
'FAIL-ACT))
(ARGS (CAR X) (CDDR X))))
(AND (CDR X) (PUTPROP (CAR X) (CDR X) 'FUNTYP-INFO)))))
'((ALLFILES SUBR () . 1)
(CGOL FSUBR) (CGOLREAD LSUBR) (CREATE-JOB LSUBR 3 . 5)
(FORMAT LSUBR 2 . 510.) (INF-EDIT MACRO) (LEDIT FSUBR)
(LAP FSUBR) (LAP-A-LIST SUBR () . 1)
(DUMPARRAYS SUBR () . 2) (LOADARRAYS SUBR () . 1)
(DIRECTORY LSUBR 1 . 2) (MAPALLFILES SUBR () . 2)
(MAPDIRECTORY LSUBR 2 . 3)
(SORT SUBR () . 2) (SORTCAR SUBR () . 2)
(GRIND FSUBR) (GRIND0 FSUBR) (GRINDEF FSUBR)
(SPRINTER SUBR () . 1) (TRACE FSUBR)
(LOOP MACRO) (DEFINE-LOOP-PATH MACRO)
(DEFINE-LOOP-SEQUENCE-PATH MACRO)
(DEFVST MACRO) (SETVST MACRO) (STRUCT-TYPEP SUBR () . 1)
(STRINGP SUBR () . 1)
(*:FIXNUM-TO-CHARACTER SUBR () . 1)
(*:CHARACTER-TO-FIXNUM SUBR () . 1)
(MAKE-STRING LSUBR 1 . 2) (STRING-PNPUT SUBR () . 2)
(REPLACE LSUBR 2 . 5) (SUBSEQ LSUBR 1 . 3)
(TO-LIST LSUBR 1 . 3) (TO-VECTOR LSUBR 1 . 3)
(TO-STRING LSUBR 1 . 3) (TO-BITS LSUBR 1 . 3)
(SETSYNTAX-SHARP-MACRO LSUBR 3 . 4)
(PTR-TYPEP SUBR () . 1) (EXTENDP SUBR () . 1)
(SI:MAKE-EXTEND SUBR () . 2) (SI:EXTEND LSUBR 1 . 510.)
(SI:XREF SUBR () . 2) (SI:XSET SUBR () . 3)
(SI:DEFCLASS*-1 LSUBR 3 . 4)
(ADD-METHOD SUBR () . 3) (FIND-METHOD SUBR () . 2)
(WHICH-OPERATIONS SUBR () . 1) (DESCRIBE LSUBR 1 . 2)
(SEND-AS LSUBR 3 . 510.) (LEXPR-SEND LSUBR 2 . 510.)
(LEXPR-SEND-AS LSUBR 3 . 510.)
(Y-OR-N-P LSUBR) (YES-OR-NO-P LSUBR)
(CERROR LSUBR 4 . 510.) (FERROR LSUBR 2 . 510.))))
() )
(DEFPROP %CATCHALL (FSUBR) FUNTYP-INFO)
(DEFPROP %PASS-THRU (FSUBR) FUNTYP-INFO)
(MAPC '(LAMBDA (X) (PUTPROP X 'NOTNUMP 'NOTNUMP)) ;Has no side-effects
'(
%HUNK1 %HUNK2 %HUNK3 %HUNK4 *APPEND ALPHALESSP
APPEND ARRAYDIMS ASSOC ASSQ ATOM BAKLIST
BIGP BOUNDP CONS COPYSYMBOL ERRFRAME
EVALFRAME EXPLODE EXPLODEC EXPLODEN
FILEP FIXP FLOATP GETCHAR GETL HUNK
HUNKP LAST LISTARRAY LISTIFY MAKNAM
MEMBER MEMQ NCONS NTHCDR NULL NUMBERP
PLIST PNGET REVERSE SAMEPNAMEP SIGNP
SUBLIS SUBST SYMBOLP SYSP TYPEP XCONS
))
(MAPC '(LAMBDA (X) (PUTPROP X 'EFFS 'NOTNUMP)) ;Has side-effects
'(
*ARRAY *DELETE *DELQ *NCONC *READCH *REARRAY
ALARMCLOCK ASCII CURSORPOS DELETE DELQ DUMPARRAYS
FILLARRAY GENSYM IMPLODE INTERN LOADARRAYS NCONC NRECONC
NREVERSE READCH REMOB REMPROP SASSOC SASSOC SASSQ SETPLIST
SETSYNTAX SORT SORTCAR SUSPEND TERPRI VALRET
))
(MAPC '(LAMBDA (X) (PUTPROP X 'T 'NOTNUMP)) ;Has side-effects, and returns T
'(TYO /+TYO *TYO DEPOSIT PRIN1 PRINC PRINT *PRIN1 *PRINC *PRINT))
;;; In general, function-names with ACS properties have no side-effects, except
;;; for those explicity mentioned under the NOTNUMP property above. Thus
;;; (NOT (GET x 'ACS)) is a general test for potentially-random side-effects.
(MAPC '(LAMBDA (DATA)
(MAPC '(LAMBDA (X) (AND (SYSP X) (PUTPROP X (CADAR DATA) (CAAR DATA))))
(CDR DATA)))
'(
;; ((ACS 1) IN OUT LINEL PAGEL CHARPOS LINENUM PAGENUM
;; CLEAR-INPUT CLEAR-OUTPUT FORCE-OUTPUT NAMELIST
;; TRUENAME PROBEF DELETEF DEFAULTF)
((ACS 1) FASLP)
((ACS 2) MERGEF)
;; ((ACS 3) NAMESTRING SHORTNAMESTRING)
;; ((ACS 4) RUBOUT RENAMEF ENDPAGEFN EOFFN DELETEF FILEPOS
;; LENGTHF CNAMEF)
((ACS 4) FILEP)
;; ((ACS 5) OPEN CLOSE)
;Missing are INCLUDE and LOAD, because they may cause
; totally unforseen side-effects
((ACS 1) LENGTH ADD1 SUB1 MINUS ABS FLOAT FIX
SIN COS SQRT LOG EXP ZEROP PLUSP MINUSP ODDP
1+ 1- 1+/$ 1-/$)
((ACS 1) LAST SLEEP RANDOM NOINTERRUPT EXAMINE
ARG MUNKAM ERRFRAME)
((ACS 2) PLUS TIMES EXPT DIFFERENCE QUOTIENT MAX MIN
GREATERP LESSP ATAN
*PLUS *TIMES *GREAT *QUO *DIF *LESS /\/\ /^ /^$
HAULONG HAIPART GCD BOOLE REMAINDER)
((ACS 2) GET REMPROP MEMQ RECLAIM EQUAL DEPOSIT
CONS NCONS XCONS SUBLIS NCONC *NCONC *DELQ
DELQ ASSQ ALARMCLOCK SETARG SETPLIST MAKNUM
SAMEPNAMEP ALPHALESSP GETCHARN LISTIFY
NTH NTHCDR)
((ACS 3) GENSYM FLATSIZE FLATC PNGET EVALFRAME PURIFY
LISTARRAY FILLARRAY DUMPARRAYS ARRAYDIMS
PRINT PRIN1 PRINC *PRINT *PRIN1 *PRINC
SYSP COPYSYMBOL SXHASH MAKNAM GETL
REVERSE NREVERSE NRECONC GETL PUTPROP ARGS)
((ACS 4) ASSOC SASSOC SASSQ CRUNIT)
((ACS 4) %HUNK1 %HUNK2 %HUNK3 %HUNK4)
((ACS 5) SUBST *DELETE DELETE MEMBER *APPEND APPEND
*ARRAY *REARRAY LOADARRAYS
BAKTRACE BAKLIST ERRPRINT
ALLOC *FUNCTION SUSPEND SETSYNTAX
EXPLODEC EXPLODE EXPLODEN
PNPUT INTERN IMPLODE REMOB ASCII READCH *READCH
*TERPRI TERPRI *TYO TYO /+TYO *TYI TYI TYIPEEK
CURSORPOS
GETMIDASOP GETDDTSYM PUTDDTSYM
;; UREAD UWRITE UKILL UFILE UPROBE UCLOSE UAPPEND
)))
;EVAL, *EVAL, READ, *READ and MAP series aren't here, since
; they permint random evaluations [hence random side effects]
;PAGEBPORG isn't here since it setqs BPORG, and may cause a GC.
(MAPC '(LAMBDA (INST) (PUTPROP INST 'T 'P1BOOL1ABLE))
'(AND OR NULL NOT EQ = > < COND MEMQ SIGNP))
(MAPC '(LAMBDA (INST) (PUTPROP INST 'NUMBERP 'P1BOOL1ABLE))
'(EQUAL GREATERP LESSP ODDP *GREAT *LESS ZEROP PLUSP MINUSP))
(MAPC '(LAMBDA (INST INSTN)
(PUTPROP INST
(CONS (CONS 'TLNN INSTN) (CONS 'TLNE INSTN))
'P1BOOL1ABLE)
(or (get inst 'NOTNUMP)
(putprop inst 'NOTNUMP 'NOTNUMP)))
'(ATOM NUMBERP FIXP FLOATP BIGP HUNKP SYMBOLP FIXNUMP SI:ARRAY-HEADERP)
;(175300 161000 120000 40000 20000 20 10000 100000 4000)
'(64192. 57856. 40960. 16384. 8192. 16. 4096. 32768. 2048.))
(MAPC '(LAMBDA (INST) (PUTPROP INST 'T 'CONTAGIOUS))
'(PLUS TIMES DIFFERENCE QUOTIENT *PLUS *TIMES *DIF *QUO))
(MAPC '(LAMBDA (INST) (PUTPROP INST 'T 'NUMBERP))
'(PLUS TIMES DIFFERENCE QUOTIENT *PLUS *TIMES *DIF *QUO
ABS MINUS FIX FLOAT IFIX ADD1 SUB1 REMAINDER HAULONG))
(MAPC '(LAMBDA (INST) (PUTPROP INST 'NOTYPE 'NUMBERP))
'(GREATERP LESSP *GREAT *LESS EQ EQUAL ODDP ZEROP PLUSP MINUSP))
(MAPC '(LAMBDA (X) (PUTPROP (CAR X) (CDR X) 'ARITHP))
'( (/+ PLUS FIXNUM) (+$ PLUS FLONUM)
(/- DIFFERENCE FIXNUM) (-$ DIFFERENCE FLONUM)
(/* TIMES FIXNUM) (*$ TIMES FLONUM)
(/1+ ADD1 FIXNUM) (1+$ ADD1 FLONUM)
(/1- SUB1 FIXNUM) (1-$ SUB1 FLONUM)
(// QUOTIENT FIXNUM) (//$ QUOTIENT FLONUM)
(/> GREATERP () ) (/< LESSP () )
(/\ REMAINDER FIXNUM) (/= EQUAL () )
;; (FIXNUM-IDENTITY IDENTITY FIXNUM) ;SET UP BY INITIALIZE
;; (FLONUM-IDENTITY IDENTITY FLONUM) ;SET UP BY INITIALIZE
))
)

1187
src/comlap/maklap.80 Executable file
View File

File diff suppressed because it is too large Load Diff

2573
src/comlap/phas1.86 Executable file
View File

File diff suppressed because it is too large Load Diff

287
src/comlap/srctrn.20 Executable file
View File

@@ -0,0 +1,287 @@
;;; SRCTRN -*-LISP-*-
;;; **************************************************************
;;; ***** MACLISP ***** (Initialization for COMPLR) *************
;;; **************************************************************
;;; ** (C) Copyright 1981 Massachusetts Institute of Technology **
;;; ****** This is a Read-Only file! (All writes reserved) *******
;;; **************************************************************
(setq SRCTRNVERNO '#.(let* ((file (caddr (truename infile)))
(x (readlist (exploden file))))
(setq |verno| (cond ((fixp x) file) ('/20)))))
(eval-when (eval compile)
(load '((lisp) subload)))
(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) (COMPDECLARE) (FASLDECLARE) (GENPREFIX |/|st|) )
;;;; SOURCE-TRANS for LISTP, < and >
(defun LISTP-FERROR-expander (x &aux (arg (cadr x)))
(setq x (cond ((eq (car x) 'FERROR) `(CERROR () () ,.(cdr x)))
((not (eq (car x) 'LISTP)) (barf x LISTP-FERROR-expander))
((|no-funp/|| (setq arg (macroexpand arg)))
`(OR (NULL ,arg) (EQ (TYPEP ,arg) 'LIST)))
('T (|non-simple-x/|| (car x) arg))))
(values x 'T))
(defun ML-<>-expander (form &aux op ex?)
(cond
((setq op (assq (car form) '((< . () )
(> . () )
(>= . <)
(<= . >))))
(let ((nargs (length (cdr form))))
(declare (fixnum nargs))
(if (not (<= 2 nargs 510.)) (dbarf form WRNG-NO-ARGS))
;; << is the name of the function -- >> is name of its inversion,
;; if an inversion must be used instead of the name directly.
(let (((<< . >>) op)
((a b) (cdr form))
c)
(cond ((= nargs 2)
;; Simple case -- 2 args only
(if >> (setq form `(NOT (,>> ,a ,b)) ex? 'T)))
((and (= nargs 3)
(not (|side-effectsp/|| a))
(not (|side-effectsp/|| b))
(not (|side-effectsp/|| (setq c (cadddr form)))))
;; Remember |side-effectsp/|| may macroexpand. "between-p",
(let* ((bb (if (+INTERNAL-DUP-P b) b (si:gen-local-var)))
(body `(AND (,<< ,a ,bb) (,<< ,bb ,c))))
;; Maybe a 'lambda' wrapper?
(if (not (eq bb b))
(setq body `((LAMBDA (,bb) ,body) ,b)))
(setq form body ex? 'T)))
('T ;; Must bind all args, even though each one appears only
;; once; otherwise its code will not get run when a>b.
;; "a" must be EVAL'd first!
(let ((arglist (cdr form)) ga gb letlist body)
(si:gen-local-var ga)
(setq letlist `((,ga ,(car arglist))))
(mapc #'(lambda (ll)
(si:gen-local-var gb)
(push `(,gb ,ll) letlist)
(push (cond (>> `(NOT (,>> ,ga ,gb)))
('T `(,<< ,ga ,gb)))
body)
(setq ga gb))
(cdr arglist))
(setq form `(LET ,(nreverse letlist)
(AND ,.(nreverse body)))
ex? 'T))))))))
(values form ex?))
;;;; LOAD-BYTE, LDB, etc
(defmacro SI:PICK-A-MASK (size) `(LSH -1 (- ,size 36.)))
(defun SI:EVALUATE-NUMBER? (x)
(prog (cnst-fl)
A (if (atom (setq x (macroexpand x)))
(return (if (numberp x) x))
(if (eq (car x) 'QUOTE)
(progn (setq x (cadr x)) (go A))))
(cond ((memq (car x) '(+ - * // +$ -$ *$ //$ \ 1+ 1- 1+$ 1-$ ^ ^$
PLUS DIFFERENCE TIMES QUOTIENT SUB1 ADD1
REMAINDER EXPT ASH LSH ROT BOOLE FIX IFIX
FLOAT FSC SQRT SIN COS LOG EXP ATAN
LDB LOAD-BYTE DEPOSIT-BYTE DPB HAULONG HAIPART))
() )
((memq (car x) '(LENGTH GETCHARN FLATC FLATSIZE SXHASH))
(setq cnst-fl 'T))
('T (return () )))
(if (do ((l (cdr x) (cdr l)) (y))
((null l) 'T)
(setq y (macroexpand (car l)))
(or (if cnst-fl
(|constant-p/|| y)
(si:evaluate-number? y))
(return () )))
(return (eval x)))))
;; LOAD-BYTE is similar to PDP-10 LDB, but "position" and "size" are separate
(defun FOO-BYTE-EXPANDER (l)
(let (((name word position size val) l)
(fl 'T)
byte-len byte-displ (byte-mask 0) ldbp nval)
(declare (fixnum byte-mask))
(setq word (macroexpand word)
position (macroexpand position)
size (macroexpand size))
(if val (setq val (macroexpand val)))
(setq ldbp (eq name 'LOAD-BYTE))
(cond
((setq byte-len (si:evaluate-number? size))
(or (and (fixnump byte-len)
(not (< byte-len 0))
(not (> byte-len 36.)))
(dbarf l |Bad 'byte-length'|))
(setq byte-mask (si:pick-a-mask byte-len))
(setq l
(cond
((= byte-len 0) (if ldbp ''0 `(PROG2 () ,word ,val)))
((= byte-len 36.) (if ldbp `,word `(PROG2 ,word ,val)))
((setq byte-displ (si:evaluate-number? position))
(or (and (fixnump byte-displ)
(not (< byte-displ 0))
(not (> (+ byte-displ byte-len) 36.)))
(dbarf l |Bad 'position'|))
(let ((nword (si:evaluate-number? word))
(shift-mask (lsh byte-mask position)))
(declare (fixnum shift-mask))
(cond
(ldbp
(cond (nword (load-byte nword position byte-len))
('T (and (not (= 0 position))
(setq word `(LSH ,word ,(- position))))
`(BOOLE 1 ,word ,byte-mask))))
('T (if (setq nval (si:evaluate-number? val))
(setq nval (logand nval byte-mask)))
(cond
((and nword nval)
(deposit-byte nword position byte-len nval))
(nword
(let ((lsher `(LSH ,val ,position)))
(if (= 0 (setq nword (boole 4 nword shift-mask)))
lsher
`(BOOLE 7 ,nword ,lsher))))
((let ((masked-word `(BOOLE 4 ,word ,shift-mask)))
(if (and nval (= nval 0))
masked-word
`(BOOLE 7 ,masked-word
,(if nval
(lsh nval position)
`(BOOLE 1 ,val ,shift-mask)))))))))))
(ldbp `(BOOLE 1 (LSH ,word (- ,position)) ,byte-mask))
('T (setq l () fl () )))))
((not (+internal-permutible-p (list word position size val)))
(setq l () fl () ))
(ldbp
(setq l `(BOOLE 1 (LSH ,word (- ,position)) (SI:PICK-A-MASK ,size))))
((prog (byte-masker bindings more-decls
shifted-mask shifted-byte deposit-zero? action)
(si:gen-local-var byte-masker)
(setq byte-displ (si:evaluate-number? position)
nval (si:evaluate-number? val)
deposit-zero? (and (fixnump nval) (= nval 0))
bindings `((,byte-masker (SI:PICK-A-MASK ,size)))
shifted-byte (if deposit-zero?
0
(progn (if nval (setq val nval))
`(BOOLE 1 ,val ,byte-masker)))
shifted-mask byte-masker )
(cond ((null byte-displ)
(si:gen-local-var byte-displ)
(setq more-decls (list byte-displ))
(push `(,BYTE-DISPL ,position) bindings)))
(cond ((or (not (fixnump byte-displ))
(not (= byte-displ 0)))
(setq shifted-mask `(LSH ,shifted-mask ,BYTE-DISPL))
(if (not deposit-zero?)
(setq shifted-byte `(LSH ,shifted-byte ,BYTE-DISPL)))))
(setq action `(BOOLE 4 ,word ,shifted-mask))
(if (not deposit-zero?)
(setq action `(BOOLE 7 ,action ,shifted-byte)))
(setq l `(LET ,bindings
(DECLARE (FIXNUM ,BYTE-MASKER ,.more-decls))
,action)))))
(values l fl)))
(defun LDB-expander (l)
(let ((ldbp (eq (car l) 'LDB))
(more? (cdr l))
(fl 'T)
word val nval bp num-bp? tem)
(if (not ldbp) (setq val (macroexpand (car more?)) more? (cdr more?)))
(setq bp (macroexpand (car more?)) word (macroexpand (cadr more?)))
(setq num-bp? (si:evaluate-number? bp))
(values
(cond
((not num-bp?)
;;Non-constant 'bp' case -- don't even try optimizations
(setq fl () ))
((let ((pos (load-byte bp 6 6))
(size (load-byte bp 0 6)))
(declare (fixnum pos size))
(cond (ldbp `(LOAD-BYTE ,word ,pos ,size))
((cond ((setq tem (si:evaluate-number? val))
(setq nval tem)
'T)
((setq tem (si:evaluate-number? word))
(setq word tem)
'T))
`(DEPOSIT-BYTE ,word ,pos ,size ,val))
('T ;;When both the 'word' and 'newbyte' are computed up, then
;; must worry about order of evaluation and side-effects
(let ((g (si:gen-local-var)))
`(LET ((,g ,val))
(DECLARE (FIXNUM ,g))
(DEPOSIT-BYTE ,word ,pos ,size ,g))))))))
fl)))
;;;; bitwise logical operations.
(defun ML-trans-expander (form &aux (ex? 'T))
(let ((fun (car form))
(nargs (length (cdr form)))
(oform form)
(interval '(1 . 1))
op)
(declare (fixnum nargs))
(cond ((eq fun 'LOGNOT)
(setq form `(BOOLE 10. ,(cadr form) -1)))
((setq op (cdr (assq fun '((LOGAND . 1)
(LOGIOR . 7)
(LOGXOR . 6)))))
(setq interval '(2 . 510.)
form `(BOOLE ,op ,.(cdr form))))
((setq op (cdr (assq fun '((FLONUMP . (FLOATP X))
(EVENP . (NOT (ODDP X)))))))
(setq form (subst (cadr form) 'X op)))
('T (setq ex? () )))
(and ex?
(not (<= (car interval) nargs (cdr interval)))
;; (or (< nargs (car interval)) (> nargs (cdr interval)))
(dbarf oform WRNG-NO-ARGS)))
(values form ex?))
(mapc
#'(lambda (y)
(let (((fun . l) y) z)
(mapc #'(lambda (x)
(or (memq fun (setq z (get x 'SOURCE-TRANS)))
(putprop x (cons fun z) 'SOURCE-TRANS))
(or (getl x '(SUBR LSUBR))
(equal (get x 'AUTOLOAD) #%(autoload-filename MLSUB))
(putprop x #%(autoload-filename MLSUB) 'AUTOLOAD)))
l)))
'((ML-trans-expander LOGAND LOGIOR LOGXOR LOGNOT FLONUMP EVENP)
(ML-<>-expander < > <= >= )
(LISTP-FERROR-expander LISTP FERROR)
(foo-byte-expander LOAD-BYTE DEPOSIT-BYTE)
(LDB-expander LDB DPB)))