;;; GGLOAD -*-LISP-*- ;;; ************************************************************** ;;; ***** Maclisp ****** Load-up EXPR Compiler - a GreenGiant **** ;;; ************************************************************** ;;; ** (c) Copyright 1980 Massachusetts Institute of Technology ** ;;; ****** this is a read-only file! (all writes reserved) ******* ;;; ************************************************************** (COMMENT FLPDL 64. REGPDL 2560. SPECPDL 2048.) ;;; Following code must come before everything else, so that only the ;;; important symbols get on the copy of the initial OBARRAY. ;;; PURCOPYs the buckets of the initial OBARRAY copy. (comment pure ATOM list for OBARRAY) ((LAMBDA (N READTABLE *RSET) (COMMENT ;Put on both obarrays IGNORE COMPLRVERNO +INTERNAL-STRING-MARKER VECTORP VECTOR MAKE-VECTOR VREF VSET VECTOR-LENGTH TYPECASEQ PTR-TYPEP /&STRUCT STRUCT-SETF STRUCT-LET PAIRP PAIR BITSP BITS BIT RPLACBIT NIBBLE SET-NIBBLE STRING STRINGP MAKE-STRING CHAR RPLACHAR CHAR-N RPLACHAR-N *EXPR *FEXPR *LEXPR **LEXPR @DEFINE ARRAY* VERSION CHOMP CHOMPHOOK CMSGFILES COBARRAY COMPILE COMPLR EVAL-ONCE SETF-SIMPLEP-SCAN EVAL-ORDERED* COUTPUT CREADTABLE DIRECTORY EOC-EVAL EOF-COMPILE-QUEUE GENPREFIX ALLOC-MARK-RATIO GOFOO MACRO-EXPAND MACROLIST MAKLAP MSDEV MSDIR NCOMPLR NO-EXTRA-OBARRAY NOTYPE NUMFUN NUMVAR ONMLS OWN-SYMBOL RECOMPL SKIP-WARNING SOBARRAY SPECIAL SPLITFILE SQUID SREADTABLE SWITCHTABLE TOPLEVEL UNDFUNS UNSPECIAL USERATOMS-HOOKS USER-STRING-MARK-IN-FASL ) (ALLOC '(LIST (12000. 48000. 8000.) FIXNUM (1000. 10000. .25) FLONUM (256. 4096. .1) BIGNUM (256. 4096. .1) SYMBOL (2048. 6144. 512.) ARRAY (64. 512. 16.))) (SETQ *RSET T NOUUO T NORET T) (SSTATUS FEATURE COMPLR) (SETQ PUTPROP (APPEND '(STATUS SSTATUS INST INSTN IMMED CARCDR ARITHP NUMBERP NOTNUMP CONTAGIOUS COMMU BOTH CONV ACS MINUS FLOATI P1BOOL1ABLE FUNTYP-INFO ARGS |side-effectsp/|| SETF-X) (SETQ CCLOAD:PUTPROP PUTPROP))) (OR (GET 'DEFMAX 'VERSION) (LOAD '((LISP) DEFMAX))) (OR (GET 'MACAID 'VERSION) (LOAD '((LISP) MACAID))) (OR (GET 'MLMAC 'VERSION) (LOAD '((LISP) MLMAC))) (OR (GET 'LODBYT 'VERSION) (LOAD '((LISP) LODBYT))) (OR (GET (CAR (STATUS MACRO /#)) 'SUBR) (LOAD '((LISP) SHARPM))) (OR (GET (CAR (STATUS MACRO /`)) 'SUBR) (LOAD '((LISP) BACKQ))) (SETQ SAIL-MORE-SYSFUNS () ) (remob 'STRING) ;VSAID doesn't want STRING in both (SETQ CCLOAD:INITIAL-MACROS () ) (MAPATOMS '(LAMBDA (X) (AND (GET X 'MACRO) (PUSH X CCLOAD:INITIAL-MACROS)))) (SETQ IREADTABLE READTABLE) (SETQ IOBARRAY (ARRAY () OBARRAY '() )) ;Make pure copy of (DO I 0 (1+ I) (= I N) ; original obarray (STORE (ARRAYCALL T IOBARRAY I) (PURCOPY (OBARRAY I)))) '*) (- (CADR (ARRAYDIMS 'OBARRAY)) 129.) (ARRAY () READTABLE 'T) () ) (PROGN (SETQ CCLOAD:PURE PURE *PURE 'T PURE 1) (COND ((STATUS FEATURE SHARABLE) (MAPC 'DEPURIFY-SYMBOL DEPURIFY-SYMBOL) (MAPC '(LAMBDA (X) (MAPC 'DEPURIFY-SYMBOL (APPEND (CAR X) (CDR X)))) *SHARING-FILE-LIST*) (MAPC 'DEPURIFY-SYMBOL (CONS (STATUS UDIR) '(AI ML MC DSK COMLAP LISP))))) (SSTATUS FLUSH 'T) ((LAMBDA (DEFMACRO-DISPLACE-CALL DEFMACRO-CHECK-ARGS DEFMACRO-FOR-COMPILING *RSET NOUUO ) (SETQ MACROMEMO '(251.) MACRO-EXPANSION-USE 'MACROMEMO) (EVAL (PROG2 () (READ) ;Gets PROG below (AND (NOT (STATUS FASLOAD)) (INPUSH -1)) ;Closes INIT file (AND (FILEP UREAD) (CLOSE UREAD)))) (PAGEBPORG) (PURIFY 0 0 'BPORG) (SETQ PUTPROP CCLOAD:PUTPROP PURE CCLOAD:PURE *PURE () )) 'T 'T () () () ) (MAPC 'MAKUNBOUND '(CCLOAD:CLOCK-SLOWDOWN CCLOAD:CLOCK-INTERVAL CCLOAD:CLOCK-EPSILON CCLOAD:TIME-TEMP CCLOAD:OTIME-TEMP CCLOAD:FLUSH-TTY CCLOAD:DEV-DIR)) (COND ((STATUS FEATURE ITS) (CDUMP 0 '|DSK:COMLAP;TS GG|)) ('T (PRINC '|/îReady to SSAVE a GG |) (CDUMP))) ) (PROG (GL NORET LVRL FLPDL TIME RUNTIME PRSSL ALARMCLOCK SLOTX REGACS NUMACS MODELIST FASLOAD UNSFLST FXPDL REGPDL NLNVTHTBP CRUNIT CCLOAD:CLOCK-SLOWDOWN CCLOAD:CLOCK-INTERVAL CCLOAD:CLOCK-EPSILON CCLOAD:TIME-TEMP CCLOAD:OTIME-TEMP CCLOAD:FLUSH-TTY CCLOAD:DEV-DIR ) (SETQ RUNTIME (RUNTIME) TIME (TIME) CRUNIT (CRUNIT) NORET T) (SETQ CCLOAD:CLOCK-EPSILON 3.0) (SETQ NUMACS '(LAMBDA () ;TURNS ALARM OFF (ALARMCLOCK 'TIME -1) ((LAMBDA (^W ^R) (PRINC '|/îClock-OFF |)) () () ) (SETQ ALARMCLOCK () ^W T CCLOAD:FLUSH-TTY T SLOTX REGACS)) REGACS '(LAMBDA () ;TURNS ALARM ON (SETQ ALARMCLOCK MODELIST ^W () SLOTX NUMACS CCLOAD:FLUSH-TTY () CCLOAD:CLOCK-SLOWDOWN 40.0 CCLOAD:CLOCK-INTERVAL 10.) ((LAMBDA (^W ^R) (PRINC '|/îClock-ON |)) () () ) (ALARMCLOCK 'TIME 1.))) (COMMENT ;SLOTX holds either NUMACS or REGACS, to hac the ALARMCLOCK ; (NUMACS) turns ALARMCLOCK feature on ; (REGACS) turns it off ;RUNTIME is the RUNTIME before beginning ;TIME is the realTIME before beginning ;CCLOAD:CLOCK-INTERVAL is the interval between alarm rings, ;CCLOAD:CLOCK-EPSILON is the epsilonics - two tics within a ; realtime of less than CCLOAD:CLOCK-EPSILON cause the ; second to be ignored. ;CCLOAD:CLOCK-SLOWDOWN is the time at which the interval should ; be slowed, [i.e., doubled] we want alarms less often as ; time goes by ;CCLOAD:TIME-TEMP is a temporary time holder ;CCLOAD:FLUSH-TTY causes a veto on message printers ) (SETQ MODELIST '(LAMBDA (VGO) (COND (CCLOAD:FLUSH-TTY (ALARMCLOCK 'TIME -1)) (T (COND ((AND (> (-$ (SETQ CCLOAD:TIME-TEMP (TIME)) CCLOAD:OTIME-TEMP) CCLOAD:CLOCK-EPSILON) (NOT CCLOAD:FLUSH-TTY)) (PRINC '|/îUsing |) (PRINC (*QUO (FIX (*QUO (- (RUNTIME) RUNTIME) 1.0E5)) 10.0)) (PRINC '| secs so far, out of |) (PRINC (*QUO (FIX (*$ (-$ (TIME) TIME) 10.0)) 10.0)) (PRINC '/ ) (SETQ CCLOAD:TIME-TEMP (TIME)))) (COND ((> (-$ (SETQ CCLOAD:OTIME-TEMP CCLOAD:TIME-TEMP) TIME) CCLOAD:CLOCK-SLOWDOWN) (SETQ CCLOAD:CLOCK-SLOWDOWN (*$ 2.0 CCLOAD:CLOCK-SLOWDOWN) CCLOAD:CLOCK-INTERVAL (* 2 CCLOAD:CLOCK-INTERVAL)))) (ALARMCLOCK 'TIME CCLOAD:CLOCK-INTERVAL))))) (SETQ EDIBLE ()) (DEFUN EDIBLE FEXPR (L) (SETQ L (MAPCAN '(LAMBDA (X) ((LAMBDA (Y) (COND ((GET X 'RECAN) ()) (Y (REMPROP X (CAR Y)) (PUTPROP X (LIST (CAR Y) (CADR Y)) 'RECAN) (SETQ EDIBLE (CONS X EDIBLE)) (PUTPROP X (SUBST () () (CADR Y)) (CAR Y)) (LIST X)))) (GETL X '(EXPR FEXPR MACRO)))) L)) (PRINT L) (APPLY 'EDIT L)) (DEFUN RECAN FEXPR (L) (MAPCAN '(LAMBDA (X) ((LAMBDA (Y) (AND Y (REMPROP X 'RECAN) (PUTPROP X (COND ((ATOM (CAR L)) (CADR Y)) ((EQ (CAAR L) 'PURE) (PURCOPY (GET X (CAR Y)))) ((GET X (CAR Y))) ((CADR Y))) (CAR Y)) (PROG2 (SETQ EDIBLE (DELQ X EDIBLE)) (LIST X)))) (GET X 'RECAN))) (COND ((ATOM (CAR L)) L) ((CDR L))))) (SETQ ^Q () ) (SETQ CCLOAD:OTIME-TEMP (TIME)) (COND ((STATUS FEATURE ITS) (SSTATUS TTYIN 30. '(LAMBDA (VGO VGOL) (FUNCALL SLOTX))) (FUNCALL REGACS))) ;Sets up SLOTX, and starts ALARMCLOCK (AND (NOT CCLOAD:FLUSH-TTY) (PRINC '|(In LISP version |) (PRINC (STATUS LISPV)) (PRINC '|)|)) (OR (NOT (STATUS FEATURE ITS)) (NOT (STATUS HACTR)) (VALRET '|// :JCL/îGGJ:VP |)) (SETQ CCLOAD:DEV-DIR (COND ((STATUS FEATURE ITS) '(DSK COMLAP)) ((AND (STATUS FEATURE DEC20) (PROBEF '((PS MACLISP) COMPLR LSP))) '(PS MACLISP)) ((LIST 'DSK (STATUS UDIR))))) C (OR (GET 'LET 'VERSION) (LOAD '((LISP) LET))) (OR (GET 'DEFMACRO 'VERSION) (LOAD '((LISP) DEFMACRO))) (OR (GET 'GETMIDASOP 'VERSION) (LOAD '((LISP) GETMIDASOP))) (OR (GET 'BS 'FSUBR) (LOAD '((LISP) BS))) (SETQ FXPDL (COND ((STATUS FEATURE ITS) '(>)) ('T '(LSP)) )) (SETQ REGPDL '(LAMBDA (X) (COND ((PROBEF (SETQ GL `(,CCLOAD:DEV-DIR ,X ,.FXPDL))) (AND (NOT CCLOAD:FLUSH-TTY) (PRINC '|/îLoading EXPR | TYO) (PRIN1 X TYO)) (LOAD GL) (AND (NOT CCLOAD:FLUSH-TTY) (PRINC '|/î (| TYO) (PRIN1 X) (PRINC '| version number | TYO) (PRINC (SYMEVAL (COND ((EQ X 'FASLAP) 'FASLVERNO) ((IMPLODE (NCONC (EXPLODEN X) '(V E R N O)))))) TYO) (PRINC '|) | TYO))) ('T (PRINC '|You Lose, Bunkie! Where is this file?|) (BREAK CANT-FIND-FILE))))) (COND (FLPDL ;() if FASLAP not to be loaded (FUNCALL REGPDL 'FASLAP))) (MAPC REGPDL '(CDMACS COMPLR PHAS1 COMAUX INITIA MAKLAP)) (AND (NOT CCLOAD:FLUSH-TTY) (PRINC '|/îInitializing |)) (INITIALIZE MACRO) (AND (STATUS FEATURE ITS) (ALARMCLOCK 'TIME -1)) (GCTWA) (COND (CCLOAD:FLUSH-TTY (GC)) ('T ((LAMBDA (^D) (GC)) 'T) (PRINC '|/îDumping a GREEN GIANT!|) (PRINC '|/îTotal Time = |) (PRINC (*QUO (FIX (*QUO (- (RUNTIME) RUNTIME) 1.0E5)) 10.0)) (PRINC '| secs out of |) (PRINC (*QUO (FIX (*$ (-$ (TIME) TIME) 10.0)) 10.0)) (TERPRI))) (SETQ ALARMCLOCK () ^Q () ^W () ) )