perm filename CCLOAD.OLD[MAC,LSP]14 blob sn#493490 filedate 1980-01-26 generic text, type T, neo UTF8
;;;   CCLOAD 						  -*-LISP-*-
;;;   **************************************************************
;;;   ***** Maclisp ****** CCLOAD - Loader for COMPLR **************
;;;   **************************************************************
;;;   ** (c) Copyright 1980 Massachusetts Institute of Technology **
;;;   ****** this is a read-only file! (all writes reserved) *******
;;;   **************************************************************

 (COMMENT CORE 80. BPS 64000.) (print 'Ncomplr)(sstatus features ncomplr)
;(COMMENT CORE 80. BPS 23000.) (print 'Bcomplr)(sstatus features bcomplr)

;This will compose a MACLISP compiler from the following files:
;	   LISP;  BACKQ  FASL		(BACKQ.FAS on TOPS-10 systems)
;	   LISP;  DEFMAC FASL		(DEFMAC.FAS on TOPS-10 systems)
;	   LISP;  DEFMAX FASL		(DEFMAX.FAS on TOPS-10 systems)
;	   LISP;  MACAID FASL		(MACAID.FAS on TOPS-10 systems)
;	   LISP;  GETMID FASL		(GETMID.FAS on TOPS-10 systems)
;	   LISP;  SETF	 FASL		(SETF.FAS on TOPS-10 systems)
;	   LISP;  LET    FASL		(LET.FAS on TOPS-10 systems, except for
;						Stanford system where not used)
;          COMLAP;COMPLR FASL		(COMPLR.FAS on TOPS-10 systems)
;		  PHAS1  FASL		(PHAS1.FAS on TOPS-10 systems)
;		  COMAUX FASL		(COMAUX.FAS on TOPS-10 systems)
;		  INITIA FASL		(INITIA.FAS on TOPS-10 systems)
;		  MAKLAP FASL		(MAKLAP.FAS on TOPS-10 systems)
;		  FASLAP FASL		(FASLAP.FAS on TOPS-10 systems)
;	   [	 663CF FASL]		;assuming COMPLR version 663
;	   [	 263FF FASL]		;assuming FASLAP version 223
;Additionally, a gc-daemon and many other help files are loaded in the
;  SAIL version.
;Ordinarily, this file will be used as an "INIT" file, but it can be
;  directly loaded into a running lisp, using any of LOAD, or UREAD.

;Ordinarily the result will be :PDUMPI'd (by SUSPEND) as 
;   COMLAP;CL.DMP <complrverno>  [there is a link on SYS for TS COMPLR
;				to COMLAP;CL.DMP >]
; however, if (STATUS FEATURE EXPERIMENTAL) is non-null, then they
; will go out on JONL directory.  Thus there is a link for XCOMPLR to
; JONL;XC.DMP >


;;; 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.
;;; And even then, STRING doesn'T want to be on it!


((LAMBDA (N READTABLE) 
	 (COMMENT   ;Put on both obarrays
		   VECTORP VECTOR MAKE-VECTOR VREF VSET VECTOR-LENGTH  
	           *EXPR *FEXPR *LEXPR **LEXPR @DEFINE ARRAY*
		   CHOMP CHOMPHOOK CMSGFILES COBARRAY COMPILE COMPLR
		   COMPLRVERNO +INTERNAL-STRING-MARKER
		   COUTPUT CREADTABLE DIRECTORY EOC-EVAL
		   EOF-COMPILE-QUEUE GENPREFIX
		   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 '(FIXNUM (2048. 10240. .25) FLONUM (256. 4096. .10) 
		  BIGNUM (256. 4096. .10) SYMBOL (1536. 8192. .25) 
		  ARRAY (64. 1024. 64.) ))
	 (AND (STATUS FEATURE ITS) (ALLOC '(LIST (14336. 40960. .35))))
	 (SETQ *RSET () NOUUO () NORET 'T) 
	 (SETQ CCLOAD:PUTPROP PUTPROP  CCLOAD:PURE PURE  *PURE 'T )
	 (COND ((STATUS FEATURE PAGING) (SETQ PURE 1))
	       ((STATUS FEATURE SAIL)
		(COND ((STATUS FEATURES NCOMPLR)
		       (SETQ PURE 1))
		      ((STATUS FEATURES BCOMPLR)
		       (SETQ PURE -1))
		      (T (PRINC '|PURE SWITCH LOSING|)(QUIT)))) 
	       ('T (SETQ PURE -1)))
	 (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) 
			       CCLOAD:PUTPROP))
	 (OR (GET 'DEFMAX 'VERSION) (LOAD '((LISP) DEFMAX)))
	 (OR (STATUS FEATURE MACAID) (LOAD '((LISP) MACAID)))
;	 (OR (GET (CAR (STATUS MACRO /#)) 'SUBR)
;	     (LOAD '((LISP) SHARPM)))
	 (OR (GET (CAR (STATUS MACRO /`)) 'SUBR)
	     (LOAD '((LISP) BACKQ)))
	 (SETQ SAIL-MORE-SYSFUNS () )
	 (COND ((STATUS FEATURE SAIL) 
		(FASLOAD (DSK (MAC LSP)) MATCH FAS)
		(FASLOAD (DSK (MAC LSP)) STRING FAS))
	       ('T (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))))
	 (SSTATUS FEATURE NOLDMSG)
	 (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 
  (AND (STATUS FEATURE SAIL)
       (SETQ CCLOAD:PURESEG (EQUAL PURE -1)))
  (PROG (GL LVRL TIME RUNTIME PUTPROP ALARMCLOCK SLOTX REGACS 
	 NUMACS MODELIST FASLOAD UNSFLST FXPDL REGPDL NLNVTHTBP 
	 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))
	(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 ↑Q () )
	(AND (STATUS FEATURE EXPERIMENTAL) 
	     (NOT (STATUS FEATURE XC))
	     (SSTATUS FEATURE XC))
	(COND ((STATUS FEATURE ITS)
	       (SETQ CCLOAD:CLOCK-EPSILON 3.0)
	       (SETQ NUMACS '(LAMBDA () 		;TURNS ALARM OFF
			      (ALARMCLOCK 'TIME -1)
			      (PRINC '|/
Clock-OFF | TYO)
			      (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.) 
			      (PRINC '|/
Clock-ON | TYO)
			      (ALARMCLOCK 'TIME 1.))
		     MODELIST '(LAMBDA (VGO) 
				(COND (CCLOAD:FLUSH-TTY (ALARMCLOCK 'TIME -1))
				      ('T (SETQ CCLOAD:TIME-TEMP (TIME))
					  (COND ((AND (NOT CCLOAD:FLUSH-TTY)
						      (> (-$ CCLOAD:TIME-TEMP 
							     CCLOAD:OTIME-TEMP) 
							 CCLOAD:CLOCK-EPSILON))
						 (TERPRI TYO)
						 (PRINC '|Using | TYO) 
						 (SETQ CCLOAD:TIME-TEMP 
						       (*QUO (- (RUNTIME) RUNTIME) 
							     1.0E5) )
						 (PRINC (*QUO (FIX CCLOAD:TIME-TEMP) 
							      10.0) 
							TYO)
						 (PRINC '| secs so far, out of | TYO)
						 (PRINC (*QUO (FIX (*$ (-$ (TIME) TIME) 10.0))
							      10.0) 
							TYO)
						 (PRINC '| |  TYO)
						 (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))) ))
		(SSTATUS TTYIN 30. '(LAMBDA (VGO VGOL) (FUNCALL SLOTX)))
		(FUNCALL REGACS)))						;Sets up SLOTX, and starts ALARMCLOCK
    B	(SETQ CCLOAD:OTIME-TEMP (TIME))
	(AND (NOT CCLOAD:FLUSH-TTY)
	     (PRINC '|/
  (In LISP version | TYO)
	     (PRINC (STATUS LISPV) TYO)
	     (PRINC '|)|) TYO)
	(OR (NOT (STATUS FEATURE ITS))
	    (NOT (STATUS HACTR))
	    (VALRET (COND ((STATUS FEATURE XC)
			   '|↔≠/:JCL/
XCOMPL≠≠J:VP |)
			  ('|↔≠/:JCL/
COMPLR≠≠J:VP |))))
	(AND PURE (PAGEBPORG)) 
	(SETQ CCLOAD:DEV-DIR (COND ((STATUS FEATURE ITS) '(DSK COMLAP))
				   ((AND (STATUS FEATURE DEC20) 
					 (PROBEF '((PS MACLISP) COMPLR FASL)))
				    '(PS MACLISP))
				   ((STATUS FEATURE SAIL) '(DSK (MAC LSP)))
				   ((LIST 'DSK (STATUS UDIR)))))
      C (SETQ NLNVTHTBP (CONS CCLOAD:DEV-DIR '(* FASL)))
	(AND (NOT (STATUS FEATURE ITS))
	     (NOT (PROBEF (CONS CCLOAD:DEV-DIR '(COMPLR FASL))))
	     (PROG2 (PRINC '|/
;Please set up "CCLOAD:DEV-DIR" to a list of the device and directory /
;names to use for the loading the COMPLR and FASLAP FASL files/
| TYO)
		    (BREAK ULUZ)
		    (GO C)))
	(COND ((NULL (GETSP (COND ((SIGNP L PURE) 12000.)
				  ((STATUS FEATURE SAIL) 50000.)
				  (43000.))))
	       (TERPRI)
	       (PRINC '|;Can't get enough Binary Program Space - You have lost badly!!|)
	       (TERPRI)
	       (BREAK ULUZ)
	       (GO C)))

;;; ### LOAD ALL AUTOLOAD FILES
	(SETQ 
	  LVRL 
	  '(LAMBDA (REGPDL)
	    (COND ((GET (CAR REGPDL) (CADR REGPDL))) 
		  ((OR (AND (SETQ GL (GET (CAR REGPDL) 'AUTOLOAD)) (PROBEF GL))
		       (PROBEF (SETQ GL (LIST '(LISP) (CADDR REGPDL) 'FASL)))
		       (AND (SETQ GL (MERGEF NLNVTHTBP (CADDR REGPDL)))
			    (PROBEF GL)))
		   (COND ((NOT CCLOAD:FLUSH-TTY) 
			  (TERPRI TYO)
			  (PRINC '|;Autoloading | TYO)
			  (PRINC (CADR GL) TYO) 
			  (PRINC '| | TYO)
			  (PRINC (CADDR GL) TYO)
			  (PRINC '| for | TYO)
			  (PRIN1 (CAR REGPDL) TYO)))
		   (LOAD GL))
		  ('T (PROG (↑Q ↑R ↑W)
			    (TERPRI)
			    (PRINC '/;)
			    (PRINC (CAR REGPDL))
			    (PRINC '| has not been defined.  Please load |)
			    (PRINC (CADDR REGPDL))
			    (PRINC '| file, and resume by <altmode>P |)
			    (BREAK WAIT-FOR-LOADING)) ))))
	(COND ((STATUS FEATURE SAIL)
	       (HELP)
	       (FUNCALL LVRL '(GC-OVERFLOW-DAEMON SUBR DEMON))
	       (SETQ GC-OVERFLOW 'GC-OVERFLOW-DAEMON)
	       (DEFUN SAVE-COMPILER (GL)
		      (CDUMP (MAKNAM (APPEND (EXPLODEN '|SAVE |)
					     (EXPLODEN GL))))))
	      ('T (FUNCALL LVRL '(GC-DAEMON SUBR GCDEMN))))
	(MAPC LVRL '( (LET MACRO LET)
		      (DEFMACRO MACRO DEFMACRO) 
		      (GETMIDASOP SUBR GETMIDASOP)
		      (+INTERNAL-SETF-X SUBR SETF) ))

;;; ### LOADING MAIN COMPLR FILES
	(SETQ LVRL '(LAMBDA (REGPDL)
		     (COND ((PROBEF (SETQ GL (CONS CCLOAD:DEV-DIR 
						   (COND ((ATOM REGPDL) 
							  (CONS REGPDL '(FASL)))
							 (REGPDL)))))
			    (COND ((NOT CCLOAD:FLUSH-TTY) 
				   (TERPRI TYO)
				   (PRINC '|	  Fazloading |)
				   (PRINC REGPDL TYO)
				   (PRINC '| FASL | TYO)))
			    (LOAD GL)
			    (COND ((AND (NOT CCLOAD:FLUSH-TTY) 
					(SETQ GL (COND ((EQ REGPDL 'FASLAP)
							'FASLVERNO) 
						       ((IMPLODE 
							 (NCONC 
							  (EXPLODEC REGPDL)
							  '(V E R N O))))))
					(BOUNDP GL)
					(SETQ GL (SYMEVAL GL)))
				   (TERPRI TYO)
				   (PRINC '|	       (|)
				   (PRINC REGPDL TYO)
				   (PRINC '| version number | TYO)
				   (PRINC GL TYO)
				   (PRINC '|) | TYO) )))
			   ('T (PROG (↑Q ↑R ↑W)
				 (TERPRI)
				 (PRINC '/;)
				 (PRINC REGPDL)
				 (PRINC '| FASL has not been found.  Please load it, and resume by <altmode>P |)
				 (BREAK ULUZ-BUNKIE))))))
	(MAPC LVRL '(COMPLR PHAS1 COMAUX FASLAP MAKLAP INITIA))
	(AND (PROBEF (LIST CCLOAD:DEV-DIR 
			   (SETQ GL (MAKNAM (NCONC (EXPLODEN COMPLRVERNO)
						   '(C F))))
			   'FASL))
	     (FUNCALL LVRL GL))
	(AND (PROBEF (LIST CCLOAD:DEV-DIR 
			   (SETQ GL (MAKNAM (NCONC (EXPLODEN COMPLRVERNO)
						   '(F F))))
			   'FASL))
	     (FUNCALL LVRL GL))
	(COND ((STATUS FEATURE SAIL)
	       ((LAMBDA (PURE)
			(FUNCALL LVRL (COND ((AND (EQ GL 'DIRECT) 
						  (STATUS FEATURE DDT))
					     '(DIRECT DFA))
					    ('DIRECT)))) ())
	       (MAPC LVRL '(EREAD MACROD NCOREQ LOADED))
	       (SETQ SAIL-MORE-SYSFUNS 
		     (APPEND '(EREAD EOPEN ELOAD UGREAT1 REQUIRE EDIT CODE 
				MACRODEF MACROBIND TRANS TRANSDEF MAIL %MATCH 
				%CONTINUE %CONTINUE-MATCH %CHAR1 %MATCH-LOOKUP 
				%%EXPAND%% %%EXPAND1%% %%%STRING%%% )
			     SAIL-MORE-SYSFUNS))
	       (MAPC '(LAMBDA (X) 
			(COND ((GET (CAR X) 'AUTOLOAD)
			       (AND (CDDR X) (ARGS (CAR X) (CDDR X)))
			       (AND (CDR X) (PUTPROP (CAR X) (CDR X) 'FUNTYP-INFO))))) 
		     '((EREAD FSUBR) (EOPEN LSUBR 0 . 4) (ELOAD SUBR () . 1)
			(UGREAT1 SUBR  () . 1) (REQUIRE FSUBR) (EDIT FSUBR) 
			(CODE FSUBR) (MAIL FSUBR))) ))
  	(COND ((NOT CCLOAD:FLUSH-TTY) 
	       (TERPRI TYO)
	       (PRINC '|Initializing | TYO)))
	(AND |carcdrp/|| 
	     (MAPC '(LAMBDA (X) (|carcdrp/|| X)) 	;Make CARCDR props
		   '(CAR   CDR  CDDR  CDDDR  CDDDDR  	; exist for a few
		     CDAR CADR CADDR CADDDR))) 
	(INITIALIZE)
	(COND ((STATUS FEATURE ITS) (ALARMCLOCK 'TIME -1))
	      ('T (SSTATUS LINMO 'T)))
	(COND ((NOT CCLOAD:FLUSH-TTY)
	       (TERPRI TYO)
	       (PRINC '|Total Time = | TYO)
	       (PRINC (*QUO (FIX (*QUO (- (RUNTIME) RUNTIME) 1.0E5)) 
			    10.0) 
		      TYO)
	       (PRINC '| secs out of | TYO)
	       (PRINC (*QUO (FIX (*$ (-$ (TIME) TIME) 10.0)) 10.0) TYO)
	       (TERPRI)))
	(SETQ ALARMCLOCK () ↑Q () ↑W () ))
  (AND (FILEP UREAD) (CLOSE UREAD))
  (INPUSH -1)			;Closes INIT file, if any, or else LOAD file
  (AND (STATUS SSTATUS FLUSH) (SSTATUS FLUSH 'T))
  (SETQ PUTPROP CCLOAD:PUTPROP)
  (MAPC 'REMOB 
	(MAPCAR 'MAKUNBOUND 
		'(CCLOAD:CLOCK-SLOWDOWN CCLOAD:CLOCK-INTERVAL 
		  CCLOAD:CLOCK-EPSILON CCLOAD:TIME-TEMP CCLOAD:DEV-DIR 
		  CCLOAD:OTIME-TEMP CCLOAD:FLUSH-TTY CCLOAD:PUTPROP  )))
  (GCTWA)
  (NORET () )
  (PRINC (COND ((STATUS FEATURE DEC20) '|Ready to SAVE as COMPLR.EXE.|)
	       ((NOT (STATUS FEATURE ITS))
		'|Ready to SSAVE as COMPLR.SAV (or .SHR,.LOW)/
Version number = |)
	       ((OR (NOT (FIXP PURE)) 
		    (STATUS FEATURE XC))
		'|Dumping eXperimentalCOMPLr on JONL;XC.DMP |)
	       ('T '|Dumping COMLAP;CL.DMP |))
	 TYO)
  (PRINC COMPLRVERNO TYO)
  (TERPRI)
  (COND ((AND (STATUS FEATURE ITS) PURE) (PAGEBPORG) (PURIFY 0 0 'BPORG)))
  (SETQ PURE CCLOAD:PURE  *PURE () )
  (COND ((STATUS FEATURE ITS) 
	 (CDUMP 0 (MAKNAM (NCONC (EXPLODEN (COND ((OR (NOT (FIXP CCLOAD:PURE))
						      (STATUS FEATURE XC))
						  '|DSK:JONL;XC.DMP |)
						 ('T '|COMLAP;CL.DMP |)))
				 (PROG2 (MAKUNBOUND 'CCLOAD:PURE)
					(EXPLODEN COMPLRVERNO))))))
	('T (MAKUNBOUND 'CCLOAD:PURE) 
	    (COND ((STATUS FEATURE SAIL) 
		   (COND (CCLOAD:PURESEG 
			     (MAKUNBOUND 'CCLOAD:PURESEG)
			     (CDUMP '|save sys:bcompl| 
				    '(bcompl shr sys (1 3))))
			 ('T (MAKUNBOUND 'CCLOAD:PURESEG)
			     (CDUMP '|Save sys:ncompl|))))
		  ('T (MAKUNBOUND 'CCLOAD:PURESEG) (CDUMP))) ))
)


βββ