153 lines
5.1 KiB
Scheme
153 lines
5.1 KiB
Scheme
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
|
|
|
; This is the main entry point to the compiler. It returns a template
|
|
; that will execute the forms (each of which is a node).
|
|
;
|
|
; This is written in a somewhat odd fashion to make sure that the forms are
|
|
; not retained once they have been compiled.
|
|
|
|
;(define (compile-forms forms name)
|
|
; (if (null? forms)
|
|
; (segment->template (sequentially
|
|
; (instruction (enum op protocol) 0)
|
|
; (deliver-value (instruction (enum op unspecific))
|
|
; (return-cont #f)))
|
|
; name
|
|
; #f ;pc-in-segment
|
|
; #f) ;debug data
|
|
; (really-compile-forms forms
|
|
; (instruction (enum op protocol) 0)
|
|
; name)))
|
|
;
|
|
;(define (really-compile-forms forms segment name)
|
|
; (if (null? (cdr forms))
|
|
; (segment->template (sequentially segment
|
|
; (compile-form (car forms)
|
|
; (return-cont #f)))
|
|
; name
|
|
; #f ;pc-in-segment
|
|
; #f) ;debug data
|
|
; (really-compile-forms (cdr forms)
|
|
; (sequentially segment
|
|
; (compile-form (car forms)
|
|
; an-ignore-values-cont))
|
|
; name)))
|
|
|
|
(define (compile-forms forms name)
|
|
(if (null? forms)
|
|
(segment->template (sequentially
|
|
(instruction (enum op protocol) 0)
|
|
(deliver-value (instruction (enum op unspecific))
|
|
(return-cont #f)))
|
|
name
|
|
#f ;pc-in-segment
|
|
#f) ;debug data
|
|
(compile-forms-loop (reverse forms) name #f)))
|
|
|
|
(define (compile-forms-loop forms name next)
|
|
(if (null? forms)
|
|
next
|
|
(compile-forms-loop (cdr forms)
|
|
name
|
|
(compile-form (car forms) name next))))
|
|
|
|
; Compile a single top-level form, returning a template. NEXT is either #F or
|
|
; a template; if it is a template we jump to it after FORM.
|
|
|
|
(define (compile-form form name next)
|
|
(segment->template (sequentially
|
|
(instruction (enum op protocol) 0)
|
|
(let ((node (force-node form))
|
|
(cont (if next
|
|
an-ignore-values-cont
|
|
(return-cont #f))))
|
|
(if (define-node? node)
|
|
(compile-definition node cont)
|
|
(compile-expression node 0 cont)))
|
|
(if next
|
|
(instruction-with-literal (enum op call-template)
|
|
next
|
|
0)
|
|
empty-segment))
|
|
name
|
|
#f ;pc-in-segment
|
|
#f)) ;debug data
|
|
|
|
(define define-node? (node-predicate 'define syntax-type))
|
|
|
|
; Definitions must be treated differently from assignments: we must
|
|
; use SET-CONTENTS! instead of SET-GLOBAL! because the SET-GLOBAL!
|
|
; instruction traps if an attempt is made to store into an undefined
|
|
; location.
|
|
|
|
(define (compile-definition node cont)
|
|
(let* ((form (node-form node))
|
|
(name (cadr form)))
|
|
(sequentially (instruction-with-location (enum op literal)
|
|
(node-ref name 'binding)
|
|
(node-form name)
|
|
value-type)
|
|
(instruction (enum op push))
|
|
(compile-expression (caddr form)
|
|
1
|
|
(named-cont (node-form name)))
|
|
(deliver-value
|
|
(instruction (enum op stored-object-set!)
|
|
(enum stob location)
|
|
location-contents-offset)
|
|
cont))))
|
|
|
|
(define location-contents-offset
|
|
(cond ((assq 'location stob-data)
|
|
=> (lambda (stuff)
|
|
(let loop ((slots (cdddr stuff)) (i 0))
|
|
(if (eq? (caar slots) 'contents)
|
|
i
|
|
(loop (cdr slots) (+ i 1))))))
|
|
(else
|
|
(error "can't find location data in STOB-DATA"))))
|
|
|
|
;----------------
|
|
; Make a startup procedure from a list of initialization templates. This
|
|
; is only used by the static linker. RESUMER should be a template that
|
|
; returns a procedure that takes 5 arguments (the number the VM passes to
|
|
; the startup procedure).
|
|
|
|
(define (make-startup-procedure inits resumer)
|
|
(let ((nargs 5))
|
|
(append-templates inits
|
|
nargs
|
|
(sequentially
|
|
(maybe-push-continuation
|
|
(instruction-with-literal (enum op call-template)
|
|
resumer
|
|
0)
|
|
nargs
|
|
(fall-through-cont #f #f))
|
|
(instruction (enum op call) nargs)))))
|
|
|
|
; Return a template that accepts NARGS arguments, invokes TEMPLATES in turn,
|
|
; and then calls template FINAL on the arguments.
|
|
|
|
(define (append-templates templates nargs final)
|
|
(segment->template
|
|
(sequentially
|
|
(instruction (enum op protocol) nargs)
|
|
(reduce (lambda (template seg)
|
|
(sequentially
|
|
(maybe-push-continuation
|
|
(instruction-with-literal (enum op call-template)
|
|
template
|
|
0)
|
|
nargs
|
|
an-ignore-values-cont)
|
|
seg))
|
|
final
|
|
templates))
|
|
#f ; no name
|
|
#f ; pc-in-segment = #f
|
|
#f)) ; no debug data
|
|
|
|
(define an-ignore-values-cont (ignore-values-cont #f #f))
|
|
|