; -*- 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))))