322 lines
10 KiB
Plaintext
322 lines
10 KiB
Plaintext
;;; ----------------------------------------------------------------------------
|
||
;;;
|
||
;;; Compile the compiler 6/12/87 COMPILE.ALL
|
||
;;;
|
||
;;; This file compiles all components of the PCS system which are written
|
||
;;; in Scheme except SCOOPS and EDWIN, which are managed separately.
|
||
;;;
|
||
;;;
|
||
;;; ----------------------------------------------------------------------------
|
||
|
||
(set! pcs-debug-mode '())
|
||
|
||
(fast-load (%system-file-name "pboot.fsl"))
|
||
(fast-load (%system-file-name "pp.fsl"))
|
||
|
||
;
|
||
; The following files make up the compiler and are used to build the
|
||
; compiler.fsl and compiler.app files.
|
||
;
|
||
(define *source-compiler-autoload-files*
|
||
'("PMACROS" "PME" "PSIMP" "PCA" "PGENCODE" "PPEEP" "PASM" "PCOMP"
|
||
"PAUTO_C" "PAUTO_R" "POPCODES"))
|
||
|
||
;
|
||
; The following files make up the required "kernal" of scheme.
|
||
;
|
||
(define *source-kernal-files*
|
||
'("PSTD" "PSTD2" "PIO" "PCHREQ" "PDEBUG" "PSTL" "AUTOCOMP"))
|
||
|
||
;
|
||
; The following is a combination of the compiler and kernal used to
|
||
; build the compiler.app file.
|
||
;
|
||
(define *source-compiler-files*
|
||
(append *source-compiler-autoload-files* *source-kernal-files*))
|
||
;
|
||
; The following files must be re-compiled for the runtime only system.
|
||
; Basically all but PRIMOPS contain code with integrables which must be
|
||
; recompiled to run in a compiler-less environment. PRIMOPS must be
|
||
; created from POPCODES to create closure definitions for all the scheme
|
||
; primitives.
|
||
;
|
||
(define *runtime-compiler-files*
|
||
'("PSTD" "PSTD2" "PIO" "PCHREQ" "PRIMOPS"))
|
||
;
|
||
; The following files are the autoload files which can be used for
|
||
; either the compiler or runtime system.
|
||
;
|
||
(define *autoload-files*
|
||
'("PADVISE" "PGR" "PP" "PBOOT" "PDOS" "PFUNARG" "PSORT"
|
||
"EDIT" "PNUM2S" "PDEFSTR" "PMATH" "PWINDOWS" "PINSPECT" "OLDPMATH"))
|
||
|
||
;
|
||
; Take input file containing primitive definitions and produce
|
||
; output file of procedures
|
||
;
|
||
(define build-primops
|
||
(lambda (input-file output-file)
|
||
(letrec
|
||
((infile (open-input-file input-file))
|
||
(outfile (open-output-file output-file))
|
||
(vars '(a b c d e f g h i j))
|
||
(build-primop
|
||
(lambda (op numrands)
|
||
(if (and (number? numrands)
|
||
(not (char=? (string-ref (symbol->string op) 0) #\%)))
|
||
(let ((bvl (list-tail vars (- (length vars) numrands))))
|
||
(princ " " 'console)
|
||
(display op)
|
||
(newline outfile)
|
||
(pp `(define ,op (lambda ,bvl (,op . ,bvl))) outfile)
|
||
(newline outfile)))))
|
||
(build-prims
|
||
(lambda (lst)
|
||
(if (null? lst)
|
||
'ok
|
||
(if (eq? (caar lst) 'pcs-define-primop)
|
||
(begin
|
||
(build-primop (cadr (cadar lst)) (caddar lst))
|
||
(build-prims (cdr lst)))))))
|
||
(read-rec
|
||
(lambda (r)
|
||
(cond ((eof-object? r)
|
||
'OK)
|
||
((and (pair? r)
|
||
(eq? (car r) 'begin)
|
||
(eq? (car (cadr r)) 'pcs-define-primop))
|
||
(build-prims (cdr r))
|
||
(read-rec (read infile)))
|
||
(else
|
||
(read-rec (read infile)))))))
|
||
|
||
(newline 'console)
|
||
(princ "[Building " 'console)
|
||
(princ output-file 'console)
|
||
(princ " from " 'console)
|
||
(princ input-file 'console)
|
||
(princ "]" 'console)
|
||
(newline 'console)
|
||
|
||
(read-rec (read infile))
|
||
(close-input-port infile)
|
||
(close-output-port outfile))))
|
||
|
||
;
|
||
; Take list of files, extract all procedure definition names, and build an
|
||
; autoload list. Place the autoload definitions in fileout; the autoload
|
||
; reference file (which is also placed in the autoload definition) is
|
||
; autoref
|
||
;
|
||
(define build-auto
|
||
(lambda (filelist fileout autoref)
|
||
(letrec
|
||
((inport '())
|
||
(autolist '())
|
||
(inspect-begin
|
||
(lambda (lst)
|
||
(if (null? lst)
|
||
'ok
|
||
(if (and (pair? (car lst))
|
||
(eq? (caar lst) 'define))
|
||
(begin
|
||
(set! autolist (cons (if (atom? (cadar lst))
|
||
(cadar lst)
|
||
(car (cadar lst)))
|
||
autolist))
|
||
(display (car autolist)) (display " ")
|
||
(inspect-begin (cdr lst)))))))
|
||
(read-rec
|
||
(lambda (record)
|
||
(cond ((eof-object? record)
|
||
'OK)
|
||
((pair? record)
|
||
(if (eq? (car record) 'define)
|
||
(begin
|
||
(set! autolist
|
||
(cons (if (atom? (cadr record))
|
||
(cadr record)
|
||
(car (cadr record)))
|
||
autolist))
|
||
(display (car autolist)) (display " "))
|
||
;else
|
||
(if (eq? (car record) 'begin)
|
||
(inspect-begin (cdr record))))
|
||
(read-rec (read inport)))
|
||
(else
|
||
(read-rec (read inport))))))
|
||
(read-files
|
||
(lambda (list)
|
||
(if (null? list)
|
||
'ok
|
||
(begin
|
||
(set! inport (open-input-file
|
||
(string-append (car list) ".s")))
|
||
(newline)
|
||
(display (car list)) (display ": ")
|
||
(read-rec (read inport))
|
||
(close-input-port inport)
|
||
(read-files (cdr list))))))
|
||
)
|
||
|
||
(display "building autoload list in file : ")
|
||
(write (string-append fileout ".s"))
|
||
(newline)
|
||
|
||
(read-files filelist)
|
||
|
||
(with-output-to-file (string-append fileout ".s")
|
||
(lambda ()
|
||
(pp `(autoload-from-file
|
||
(%system-file-name ,autoref)
|
||
',(reverse autolist)
|
||
user-global-environment))))
|
||
|
||
*the-non-printing-object*)))
|
||
|
||
;
|
||
; compile the given file, writing to appropriate object file
|
||
;
|
||
(define godoit
|
||
(lambda (file)
|
||
(let ((src (string-append (filename-sans-extension file)
|
||
(if (not (string-null?
|
||
(extension-sans-filename file)))
|
||
(extension-sans-filename file)
|
||
".S")))
|
||
(obj (string-append (filename-sans-extension file)
|
||
(case compiling-compiler?
|
||
(#!false ".RTO")
|
||
(else ".SO")))))
|
||
(newline 'console)
|
||
(princ "[Compiling " 'console)
|
||
(princ src 'console)
|
||
(princ " to " 'console)
|
||
(princ obj 'console)
|
||
(princ "]" 'console)
|
||
(newline 'console)
|
||
(if (file-exists? src)
|
||
(begin
|
||
(gc)
|
||
(pcs-compile-file src obj)
|
||
(set! files-compiled (cons src files-compiled)))
|
||
(begin
|
||
(writeln "File not found!")
|
||
(set! files-not-compiled (cons src files-not-compiled))))
|
||
)))
|
||
|
||
(define *this-file* "COMPILE.ALL")
|
||
|
||
(define *do-files* nil) ;files that get compiled this time round
|
||
|
||
(define compiling-compiler?) ;if true, compiling the runtime only
|
||
|
||
(for-each (lambda (string) ; Make PCS-INITIAL-ARGUMENTS uppercase
|
||
(let loop ((n 0))
|
||
(when (<? n (string-length string))
|
||
(string-set! string n (char-upcase (string-ref string n)))
|
||
(loop (1+ n)))))
|
||
pcs-initial-arguments)
|
||
|
||
(if (or (unbound? pcs-initial-arguments) ; executing from PCS command line
|
||
(atom? pcs-initial-arguments)
|
||
(not (string-ci=?
|
||
(filename-sans-extension (car pcs-initial-arguments))
|
||
(filename-sans-extension *this-file*))))
|
||
(begin
|
||
(newline)
|
||
(writeln (integer->char 7) ;beep
|
||
"The file COMPILE.ALL is meant to be invoked ")
|
||
(writeln "from the PCS command line only.")
|
||
(reset)))
|
||
|
||
|
||
(set! pcs-initial-arguments ; remove invocation file
|
||
(cdr pcs-initial-arguments))
|
||
|
||
|
||
(let ((request ; classify request
|
||
(string->symbol
|
||
(car pcs-initial-arguments)))
|
||
(print (lambda x
|
||
(newline)
|
||
(for-each display x))))
|
||
(set! compiling-compiler? request)
|
||
(case request
|
||
(?
|
||
(print "To compile the compiler, invoke with:")
|
||
(print " pcs " *this-file* " ? - this display")
|
||
(print " pcs " *this-file* " /src - all of source compiler")
|
||
(print " pcs " *this-file* " /src file ... - compile given src files")
|
||
(print " pcs " *this-file* " /rt - all of runtime compiler")
|
||
(print " pcs " *this-file* " /rt file ... - compile given runtime files")
|
||
(print " pcs " *this-file* " /auto - all autoload files")
|
||
(print " pcs " *this-file* " /auto file ... - compile given autoload files")
|
||
(print " pcs " *this-file* " /stl - compile STL.S file")
|
||
(print " pcs " *this-file* " /noload file ... - compile without incremental load")
|
||
(newline)
|
||
(reset))
|
||
(/src
|
||
(print "Compiling source compiler.")
|
||
(newline)
|
||
(if (cdr pcs-initial-arguments)
|
||
(set! *do-files* (cdr pcs-initial-arguments))
|
||
(set! *do-files* *source-compiler-files*)))
|
||
(/rt
|
||
(set! compiling-compiler? #!false)
|
||
(print "Compiling runtime compiler.")
|
||
(newline)
|
||
(if (cdr pcs-initial-arguments)
|
||
(set! *do-files* (cdr pcs-initial-arguments))
|
||
(set! *do-files* *runtime-compiler-files*)))
|
||
(/auto
|
||
(print "Compiling autoload files.")
|
||
(newline)
|
||
(if (cdr pcs-initial-arguments)
|
||
(set! *do-files* (cdr pcs-initial-arguments))
|
||
(set! *do-files* *autoload-files*)))
|
||
(/noload
|
||
(print "Compiling arbitrary files without executing them.")
|
||
(newline)
|
||
(set! *do-files* (cdr pcs-initial-arguments)))
|
||
(else
|
||
(error (string-append "Bad request to " *this-file*) request))))
|
||
|
||
|
||
(if (not compiling-compiler?) ; if runtime, treat define-integrable
|
||
(begin ; as if it were define
|
||
(remprop 'define-integrable 'pcs*macro)
|
||
(macro define-integrable
|
||
(lambda (e)
|
||
`(define ,@(cdr e))))))
|
||
|
||
(define files-compiled '())
|
||
(define files-not-compiled '())
|
||
|
||
;;;
|
||
;;; Compile each file supplied by *do-files*.
|
||
;;; If PRIMOPS is encountered, it must be built from POPCODES, and
|
||
;;; an autoload definition created for AUTOPRIM.FSL.
|
||
;;; If AUTOCOMP is encountered, create autoload definition in
|
||
;;; AUTOCOMP.FSL, referencing COMPILER.FSL
|
||
(for-each
|
||
(lambda (file)
|
||
(cond
|
||
((string-ci=? (filename-sans-extension file) "PRIMOPS")
|
||
(build-primops "POPCODES.S" "PRIMOPS.S") ;create PRIMOPS.S
|
||
(build-auto (list "PRIMOPS") "AUTOPRIM" "PRIMOPS.FSL") ;create AUTOPRIM.S
|
||
(godoit "AUTOPRIM")) ; and compile it
|
||
((string-ci=? (filename-sans-extension file) "AUTOCOMP")
|
||
(build-auto ;create AUTOCOMP.S
|
||
*source-compiler-autoload-files* file "COMPILER.FSL"))
|
||
)
|
||
(godoit file)) ;compile file
|
||
*do-files*)
|
||
|
||
(writeln "Files compiled: " (reverse! files-compiled))
|
||
(writeln "Files not compiled: " (reverse! files-not-compiled))
|
||
|
||
; it would be nicer if PCS could set the DOS exit code
|
||
(if (not files-not-compiled)
|
||
(exit))
|
||
|