579 lines
21 KiB
Common Lisp
579 lines
21 KiB
Common Lisp
; -*- Mode: Lisp -*- Filename: pcomp.s
|
||
|
||
;--------------------------------------------------------------------------;
|
||
; ;
|
||
; TI SCHEME -- PCS Compiler ;
|
||
; Copyright 1985 (c) Texas Instruments ;
|
||
; ;
|
||
; Terry Caudill ;
|
||
; ;
|
||
; Compiler Specific runtime routines ;
|
||
; ;
|
||
;--------------------------------------------------------------------------;
|
||
|
||
; Revision history:
|
||
; 6/01/87 tc - This file was created from several of the old compiler
|
||
; files (pstd, pio, pdebug, pchreq, and pstl) in order to
|
||
; collect all the compiler-specific code.
|
||
; 6/01/87 tc - added PCS-INTEGRATE-DEFINE variable so that MIT style
|
||
; defines don't expand into named-lambda unless #T. This
|
||
; is a requirement for the R^3 Report.
|
||
; 6/01/87 tc - added string->number as autoload from PNUM2S
|
||
; 6/01/87 tc - make compiler re-entrant
|
||
; 6/01/87 rb - added more PGR functions to autoload;
|
||
; toplevel reworked so RESET doesn't affect the fluids
|
||
; INPUT-PORT and OUTPUT-PORT (this allows the system toplevel
|
||
; to run in windows other than 'CONSOLE);
|
||
; revamped PCS-INITIAL-ARGUMENTS per 3.0 changes to cmd line
|
||
; 6/01/87 tc - added MAKE-STRING as autoload for PFUNARG
|
||
|
||
;;;
|
||
;;; The following functions are related in that they all envoke the
|
||
;;; compiler in some form or fashion
|
||
;;;
|
||
(define load ; LOAD
|
||
(lambda (filename)
|
||
(let ((i-port (open-input-file filename)))
|
||
(if (null? i-port)
|
||
(error "Unable to load file" filename)
|
||
(letrec
|
||
((loop
|
||
(lambda (form)
|
||
(cond ((eof-object? form)
|
||
(close-input-port i-port)
|
||
'ok)
|
||
(else
|
||
(eval form)
|
||
(loop (read i-port)))))))
|
||
(let ((form (read i-port)))
|
||
(if (eq? form '#!fast-load)
|
||
(begin
|
||
(close-input-port i-port)
|
||
(fast-load filename))
|
||
(loop form))))))))
|
||
|
||
(define compile-file ; COMPILE-FILE
|
||
(lambda (filename1 filename2)
|
||
(if (or (not (string? filename1))
|
||
(not (string? filename2))
|
||
(equal? filename1 filename2))
|
||
(%error-invalid-operand-list 'COMPILE-FILE
|
||
filename1
|
||
filename2)
|
||
(let ((i-port (open-input-file filename1)))
|
||
(let ((o-port (open-output-file filename2)))
|
||
(set-line-length! 74 o-port)
|
||
(letrec
|
||
((loop
|
||
(lambda (form)
|
||
(if (eof-object? form)
|
||
(begin (close-input-port i-port)
|
||
(close-output-port o-port)
|
||
'ok)
|
||
(begin ; no COMPILE-FORMS
|
||
(compile-to-file form)
|
||
(set! form '()) ; for GC
|
||
(loop (read i-port))))))
|
||
(compile-to-file
|
||
(lambda (form)
|
||
(let ((cform (compile form)))
|
||
(write (list '%execute (list 'quote cform))
|
||
o-port)
|
||
(newline o-port)
|
||
(%execute cform)))))
|
||
(loop (read i-port))))))))
|
||
|
||
(define %compile-timings '())
|
||
|
||
(define %compile ; %COMPILE
|
||
(lambda (exp . time?)
|
||
(when time? (gc))
|
||
(let ((time '())
|
||
(t0 (runtime)))
|
||
(set! pcs-local-var-count 0)
|
||
(set! pcs-error-flag #!false)
|
||
(set! pcs-verbose-flag (not time?))
|
||
(set! pcs-binary-output #!false)
|
||
(set! pme= (pcs-macro-expand exp))
|
||
(if pcs-error-flag
|
||
(error "[Compilation terminated because of errors]")
|
||
(begin
|
||
(set! time (cons (- (runtime) t0) time))
|
||
(set! psimp= (pcs-simplify pme=))
|
||
(set! time (cons (- (runtime) t0) time))
|
||
(pcs-closure-analysis psimp=)
|
||
(set! time (cons (- (runtime) t0) time))
|
||
(set! pcg= (pcs-gencode psimp=))
|
||
(set! time (cons (- (runtime) t0) time))
|
||
(set! ppeep= (pcs-postgen pcg=))
|
||
(set! time (cons (- (runtime) t0) time))
|
||
(set! pasm= (pcs-assembler ppeep=))
|
||
(set! time (cons (- (runtime) t0) time))
|
||
(set! pcs-verbose-flag #!false)
|
||
(when time?
|
||
(set! %compile-timings
|
||
(cons (reverse! time) %compile-timings)))
|
||
pasm=)))))
|
||
|
||
;
|
||
; Make compiler re-entrant (or more so, at any rate). The problem arises
|
||
; when a macro evokes EVAL and thus COMPILE during macro expansion i9n PME
|
||
;
|
||
(define compile '()) ; COMPILE
|
||
|
||
(let ((ge (%set-global-environment user-global-environment)))
|
||
(set! compile
|
||
(lambda (exp)
|
||
(let* ((vc pcs-local-var-count) ; save
|
||
(vf pcs-verbose-flag)
|
||
(ef pcs-error-flag)
|
||
(bo pcs-binary-output)
|
||
(gensym-string (access string (procedure-environment gensym)))
|
||
(gensym-counter (access counter (procedure-environment gensym)))
|
||
(result (pcs-assembler (pcs-compile-to-AL exp))))
|
||
(set! pcs-local-var-count vc) ; restore
|
||
(set! pcs-verbose-flag vf)
|
||
(set! pcs-error-flag ef)
|
||
(set! pcs-binary-output bo)
|
||
(set! (access string (procedure-environment gensym)) gensym-string)
|
||
(set! (access counter (procedure-environment gensym)) gensym-counter)
|
||
(pcs-clear-registers)
|
||
result)))
|
||
(%set-global-environment ge))
|
||
|
||
(define pcs-compile-to-AL ; PCS-COMPILE-TO-AL
|
||
(lambda (exp)
|
||
(set! pcs-local-var-count 0)
|
||
(set! pcs-error-flag #!false)
|
||
(set! pcs-binary-output #!true)
|
||
(set! pcs-verbose-flag #!false)
|
||
(let ((t1 (pcs-macro-expand exp)))
|
||
(if pcs-error-flag
|
||
(error "[Compilation terminated because of errors]")
|
||
(begin
|
||
(set! exp '()) ; for GC
|
||
(pcs-clear-registers)
|
||
(let ((t2 (pcs-simplify t1)))
|
||
(pcs-closure-analysis t2)
|
||
(let ((t3 (pcs-gencode t2)))
|
||
(set! t2 '()) ; for GC
|
||
(pcs-clear-registers)
|
||
(let ((t4 (pcs-postgen t3)))
|
||
(pcs-clear-registers)
|
||
t4))))))))
|
||
|
||
(define pcs-execute-AL ; PCS-EXECUTE-AL
|
||
(lambda (al)
|
||
(let ((t1 (pcs-assembler al)))
|
||
(pcs-clear-registers)
|
||
(%execute t1))))
|
||
|
||
(define optimize! ; OPTIMIZE!
|
||
(lambda args
|
||
(let ((flag (or (null? args)(car args))))
|
||
(set! pcs-permit-peep-1 flag)
|
||
(set! pcs-permit-peep-2 flag))))
|
||
|
||
|
||
;;;; Syntax Checking Functions
|
||
;;;
|
||
;;; These functions may be used by macros and other syntax transformers
|
||
;;; to help find violations of Scheme syntax rules. Note that these
|
||
;;; check only the syntax, not semantics, of the program fragments they
|
||
;;; are defined for. It is the caller's responsibility, for example, to
|
||
;;; verify that all of the identifiers bound in a LETREC are distinct.
|
||
;;; PCS-CHK-PAIRS can't do so, because it is called to verify pairs for
|
||
;;; both LETREC and LET*.
|
||
|
||
(define pcs-chk-id ; PCS-CHK-ID
|
||
(lambda (e y)
|
||
(when (not (symbol? y))
|
||
(syntax-error "Invalid identifier in expression" y e))))
|
||
|
||
(define (pcs-chk-length= e y n) ; PCS-CHK-LENGTH=
|
||
(cond ((and (null? y)(zero? n))
|
||
'())
|
||
((null? y)
|
||
(syntax-error "Expression has too few subexpressions" e))
|
||
((atom? y)
|
||
(syntax-error (if (atom? e)
|
||
"List expected"
|
||
"Expression ends with `dotted' atom")
|
||
e))
|
||
((zero? n)
|
||
(syntax-error "Expression has too many subexpressions" e))
|
||
(else
|
||
(pcs-chk-length= e (cdr y) (sub1 n)))))
|
||
|
||
(define (pcs-chk-length>= e y n) ; PCS-CHK-LENGTH>=
|
||
(cond ((and (null? y)( < n 1))
|
||
'())
|
||
((atom? y)
|
||
(pcs-chk-length= e y -1))
|
||
(else
|
||
(pcs-chk-length>= e (cdr y) (sub1 n)))))
|
||
|
||
(define (pcs-chk-bvl e bvl dot-ok?) ; PCS-CHK-BVL
|
||
(letrec ((oops
|
||
(lambda () (syntax-error "Invalid identifier list" e))))
|
||
(cond ((atom? bvl)
|
||
(or (null? bvl)(and dot-ok? (pcs-chk-bvar bvl))
|
||
(oops)))
|
||
((pcs-chk-bvar (car bvl))
|
||
(pcs-chk-bvl e (cdr bvl) dot-ok?))
|
||
(else
|
||
(oops)))))
|
||
|
||
(define (pcs-chk-pairs e pairs) ; PCS-CHK-PAIRS
|
||
(letrec ((oops
|
||
(lambda () (syntax-error "Invalid pair binding list" e))))
|
||
(if (atom? pairs)
|
||
(or (null? pairs)
|
||
(oops))
|
||
(let ((pr (car pairs)))
|
||
(if (or (atom? pr)
|
||
(not (pcs-chk-bvar (car pr)))
|
||
(atom? (cdr pr))
|
||
(not (null? (cddr pr))))
|
||
(oops)
|
||
(pcs-chk-pairs e (cdr pairs)))))))
|
||
|
||
|
||
(define pcs-chk-bvar ; PCS-CHK-BVAR
|
||
(lambda (id)
|
||
(if (or (not (symbol? id))
|
||
(getprop id 'PCS*MACRO)
|
||
(memq id '(QUOTE LAMBDA IF SET!
|
||
BEGIN LETREC DEFINE))
|
||
(and (memq id '(T NIL))
|
||
pcs-integrate-t-and-nil))
|
||
(syntax-error "Invalid bound variable name" id)
|
||
#!true)))
|
||
|
||
;;; EXPAND, EXPAND-MACRO and EXPAND-MACRO-1 expand macro calls. EXPAND-MACRO
|
||
;;; and EXPAND-MACRO-1 only expand the outer-level form and leave sub-forms
|
||
;;; alone. EXPAND-MACRO-1 does so only once, while EXPAND-MACRO does so
|
||
;;; repeatedly until there is no change. EXPAND expands form and all subforms
|
||
;;; completely.
|
||
|
||
(define expand-macro ; EXPAND-MACRO
|
||
(lambda (exp)
|
||
(let ((expansion (expand-macro-1 exp)))
|
||
(if (or (atom? exp) (equal? expansion exp))
|
||
expansion
|
||
(expand-macro expansion)))))
|
||
|
||
(define expand-macro-1 ; EXPAND-MACRO-1
|
||
(lambda (x)
|
||
(cond ((symbol? x)
|
||
(let ((entry (getprop x 'PCS*MACRO)))
|
||
(if (null? entry)
|
||
x
|
||
(if (pair? entry)
|
||
(if (eq? (car entry) 'ALIAS)
|
||
(cdr entry))
|
||
(syntax-error "Macro or special form name used as a variable"
|
||
x)))))
|
||
((pair? x)
|
||
(let* ((f (car x))
|
||
(ef (if (pair? f) (expand-macro f) f))
|
||
(a (cdr x)))
|
||
(if (symbol? ef)
|
||
(let ((macfun (getprop ef 'PCS*MACRO)))
|
||
(cond ((null? macfun)
|
||
(cons ef a))
|
||
((pair? macfun)
|
||
(cons (cdr macfun) a))
|
||
(else
|
||
(macfun (cons ef a)))))
|
||
(cons ef a))))
|
||
(else x))))
|
||
|
||
(define expand ; EXPAND
|
||
(letrec ((expand-item
|
||
(lambda (item)
|
||
(if (pair? item) (expand item) item))))
|
||
(lambda (exp)
|
||
(let ((expansion (expand-macro exp)))
|
||
(map expand-item expansion)))))
|
||
|
||
;;;
|
||
;;; Set up EDWIN so that it may be loaded into its own environment
|
||
;;;
|
||
|
||
(define initiate-edwin ; INITIATE-EDWIN
|
||
(lambda ()
|
||
(unbind 'edwin user-global-environment)
|
||
(set! (access edwin-environment user-global-environment)
|
||
(make-hashed-environment))
|
||
(%reify! edwin-environment 0 user-initial-environment)
|
||
(autoload-from-file (%system-file-name "edwin0.fsl")
|
||
'(edwin)
|
||
edwin-environment)
|
||
(edwin)))
|
||
|
||
(define edwin initiate-edwin) ; EDWIN
|
||
|
||
;;;
|
||
;;; Set up compiler-related global variables
|
||
;;;
|
||
|
||
(BEGIN
|
||
(define %pcs-stl-debug-flag #!false)
|
||
(define %pcs-stl-history '(%PCS-STL-HISTORY)) ; getprop tag
|
||
(define pcs-local-var-count 0)
|
||
(define pcs-integrate-integrables #!true)
|
||
(define pcs-integrate-primitives #!true)
|
||
(define pcs-integrate-T-and-NIL #!true)
|
||
(define pcs-integrate-define #!true)
|
||
(define pcs-debug-mode #!false) ; debug mode OFF
|
||
(define pcs-permit-peep-1 #!true) ; optimization ON
|
||
(define pcs-permit-peep-2 #!true)
|
||
(define pcs-verbose-flag #!false)
|
||
(define pcs-display-warnings #!true)
|
||
(define pme= '())
|
||
(define psimp= '())
|
||
(define pcg= '())
|
||
(define ppeep= '())
|
||
(define pasm= '())
|
||
)
|
||
|
||
;;; Evaluation
|
||
|
||
;;; EVAL is part interpreter, but calls the compiler for complicated
|
||
;;; expressions. In particular, it does not do any bindings
|
||
;;; interpretively, since they would have to be first-class
|
||
;;; environments and the compiler might be able to do better.
|
||
|
||
(define eval
|
||
(letrec
|
||
((eval-exp
|
||
(lambda (xx env)
|
||
(let ((x (expand-macro xx)))
|
||
(if (pair? x)
|
||
(case (car x)
|
||
((QUOTE) (eval-quote x env))
|
||
((IF) (eval-if x env))
|
||
((SET!) (eval-set! x env))
|
||
((DEFINE) (eval-define x env))
|
||
((BEGIN) (eval-begin x env))
|
||
((LET
|
||
LET*
|
||
LETREC
|
||
LAMBDA ) (eval-compile x env))
|
||
((%%GET-FLUID%%) (eval-fluid x env))
|
||
((%%SET-FLUID%%) (eval-set-fluid! x env))
|
||
((THE-ENVIRONMENT) env)
|
||
((PCS-CODE-BLOCK) (eval-execute x env))
|
||
(else (eval-application x env)))
|
||
(eval-atom x env)))))
|
||
|
||
(lookup-binding ; LOOKUP-BINDING
|
||
(lambda (sym)
|
||
; The following is the object code to lookup/fetch
|
||
; the binding of sym. It must be passed to %execute with
|
||
; the desired environment.
|
||
(list 'pcs-code-block 1 4 (list sym)
|
||
'( 7 4 0 ; Ld-global r1,sym
|
||
59)))) ; exit
|
||
|
||
(eval-atom ; EVAL-ATOM
|
||
(lambda (x env)
|
||
(cond ((not (symbol? x)) x)
|
||
((memq x '(#!TRUE #!FALSE #!UNASSIGNED)) x)
|
||
(else
|
||
(let ((entry (and PCS-INTEGRATE-T-AND-NIL
|
||
(assq x '((T #T) (NIL #F))))))
|
||
(if entry
|
||
(cadr entry)
|
||
;else
|
||
(or (lookup-integrable x env)
|
||
(eval-execute (lookup-binding x) env))))))))
|
||
|
||
(lookup-integrable
|
||
(lambda (x env)
|
||
(let ((info (getprop x 'PCS*PRIMOP-HANDLER)))
|
||
(and info
|
||
(pair? info)
|
||
(eval-exp (cdr info) env)))))
|
||
|
||
(eval-quote ; EVAL-QUOTE
|
||
(lambda (x env)
|
||
(pcs-chk-length= x x 2)
|
||
(cadr x)))
|
||
|
||
(eval-id-error
|
||
(lambda (err caller env)
|
||
(syntax-error
|
||
(string-append "Invalid identifier for " caller ": ") err)))
|
||
|
||
|
||
(eval-if ; EVAL-IF
|
||
(lambda (x env)
|
||
(if (or (atom? (cdr x)) ; No Pred
|
||
(atom? (cddr x)) ; No Then
|
||
(pair? (cdddr x))) ; has ELSE
|
||
(pcs-chk-length= x x 4)
|
||
(pcs-chk-length= x x 3))
|
||
(cond ((eval-exp (cadr x) env)
|
||
(eval-exp (caddr x) env))
|
||
((pair? (cdddr x))
|
||
(eval-exp (cadddr x) env))
|
||
(else
|
||
#!FALSE))))
|
||
|
||
|
||
(set-var-value ; SET-VAR-VALUE
|
||
(lambda (sym value)
|
||
; The following is the object code code to set the value
|
||
; of a variable. It must be passed to %execute with the
|
||
; desired environment.
|
||
(list 'pcs-code-block 2 7 (list sym value)
|
||
'( 1 4 1 ; Load r1, value
|
||
15 4 0 ; St-glob-env r1,sym
|
||
59)))) ; exit
|
||
|
||
(eval-set! ; EVAL-SET!
|
||
(lambda (x env)
|
||
(pcs-chk-length= x x 3)
|
||
(let* ((id (cadr x))
|
||
(var (expand-macro id))
|
||
(value (eval-exp (caddr x) env)))
|
||
(cond ((not (pair? var))
|
||
(cond ((or (not (symbol? var))
|
||
(not (eq? var (expand-macro var))))
|
||
(eval-id-error var "SET!" env))
|
||
((getprop var 'PCS*PRIMOP-HANDLER)
|
||
; this is for primitives and define-integrables
|
||
(eval-compile x env))
|
||
(else
|
||
(eval-execute (SET-VAR-VALUE var value) env))))
|
||
(else
|
||
(eval-id-error var "SET!" env))))))
|
||
|
||
(def-var ; DEF-VAR
|
||
(lambda (sym value)
|
||
; The following is the object code code to define a variable
|
||
; in a given environment. It must be passed to %execute with the
|
||
; desired environment.
|
||
(list 'pcs-code-block 2 7 (list sym value)
|
||
'( 1 4 1 ; Load r1, value
|
||
31 4 0 ; define! value,sym
|
||
59)))) ; exit
|
||
|
||
(eval-define ; EVAL-DEFINE
|
||
(lambda (x env)
|
||
(pcs-chk-length>= x x 3)
|
||
(if (and (pair? (caddr x))
|
||
(memq (caaddr x) '(LAMBDA NAMED-LAMBDA)))
|
||
(eval-compile x env)
|
||
;else
|
||
(let* ((id (cadr x))
|
||
(var (expand-macro id))
|
||
(value (eval-exp (caddr x) env)))
|
||
(cond ((not (pair? var))
|
||
(cond ((or (not (symbol? var))
|
||
(not (eq? var (expand-macro var))))
|
||
(eval-id-error var "DEFINE" env))
|
||
((getprop var 'PCS*PRIMOP-HANDLER)
|
||
; this is for primitives and define-integrables
|
||
(eval-compile x env))
|
||
(else
|
||
(eval-execute (DEF-VAR var value) env)
|
||
id)))
|
||
(else
|
||
(eval-id-error var "DEFINE" env)))))))
|
||
|
||
|
||
(eval-begin ; EVAL-BEGIN
|
||
(lambda (x env)
|
||
(pcs-chk-length>= x x 1)
|
||
(let loop ((x (cdr x)))
|
||
(if (null? (cdr x))
|
||
(eval-exp (car x) env)
|
||
(begin
|
||
(eval-exp (car x) env)
|
||
(loop (cdr x)))))))
|
||
|
||
(lookup-fluid ; LOOKUP-FLUID
|
||
(lambda (sym)
|
||
; The following is the object code to lookup/fetch the
|
||
; fluid binding of sym. It must be passed to %execute with
|
||
; the desired environment.
|
||
(list 'pcs-code-block 1 4 (list sym)
|
||
'( 8 4 0 ; Ld_fl r1,sym
|
||
59)))) ; exit
|
||
|
||
(eval-fluid ; EVAL-FLUID
|
||
(lambda (x env)
|
||
(pcs-chk-length= x x 2)
|
||
(eval-execute (lookup-fluid (eval-exp (cadr x) env)) env)))
|
||
|
||
(set-fluid-var ; SET-FLUID-VAR
|
||
(lambda (sym value)
|
||
; The following is the object code to set the value of a
|
||
; fluid variable. It must be passed to %execute with the
|
||
; desired environment.
|
||
(list 'pcs-code-block 2 7 (list sym value)
|
||
'( 1 4 1 ; Load r1, value
|
||
16 4 0 ; St-fl r1,sym
|
||
59)))) ; exit
|
||
|
||
(eval-set-fluid! ; EVAL-SET-FLUID!
|
||
(lambda (x env)
|
||
(pcs-chk-length>= x x 2)
|
||
(let ((sym (eval-exp (cadr x) env))
|
||
(val (eval-exp (caddr x) env)))
|
||
(pcs-chk-id x sym)
|
||
(eval-execute (set-fluid-var sym val) env))))
|
||
|
||
(eval-application ; EVAL-APPLICATION
|
||
(lambda (x env)
|
||
(pcs-chk-length>= x x 1)
|
||
(let ((proc (eval-exp (car x) env)))
|
||
(when (not (or (procedure? proc)
|
||
(and (pair? proc)
|
||
(eq? (car proc) 'LAMBDA))))
|
||
(error-procedure "Attempt to call a non-procedural object"
|
||
(cons proc (cdr x))
|
||
env))
|
||
(let ((args (eval-args (cdr x) env)))
|
||
(let* ((saved-env (%set-global-environment env))
|
||
(result (apply proc args)))
|
||
(%set-global-environment saved-env)
|
||
result)))))
|
||
|
||
(eval-args ; EVAL-ARGS
|
||
(lambda (x env)
|
||
(if (null? x)
|
||
'()
|
||
(cons (eval-exp (car x) env)
|
||
(eval-args (cdr x) env)))))
|
||
|
||
(eval-compile ; EVAL-COMPILE
|
||
(lambda (x env)
|
||
(eval-execute (compile x) env)))
|
||
|
||
(eval-execute ; EVAL-EXECUTE
|
||
(lambda (x env)
|
||
(let* ((saved-env (%set-global-environment env))
|
||
(result (%execute x)))
|
||
(%set-global-environment saved-env)
|
||
result)))
|
||
|
||
) ; letrec vars
|
||
|
||
(lambda (exp . rest)
|
||
(let* ((env (cond ((null? rest)
|
||
(let ((e (%set-global-environment
|
||
user-initial-environment)))
|
||
(%set-global-environment e)
|
||
e))
|
||
((not (environment? (car rest)))
|
||
(%error-invalid-operand 'EVAL (car rest)))
|
||
(else
|
||
(car rest))))
|
||
(result (eval-exp exp env)))
|
||
result))))
|
||
|
||
|