diff --git a/TODO.org b/TODO.org index ca4b972..d822046 100644 --- a/TODO.org +++ b/TODO.org @@ -77,7 +77,7 @@ involve: *** [X] protocol *** [-] prescheme-front-end *** [-] forms -*** [ ] expand +*** [-] expand *** [ ] ps-primitives *** [ ] primitive-data *** [ ] eval-node @@ -102,6 +102,7 @@ involve: ** TODO port scheme/bcomp/node.scm ** TODO port scheme/bcomp/schemify.scm +** TODO port scheme/bcomp/package.scm ** TODO port write-one-line from scheme/big/more-port.scm * TODO prepare some compatibility tests diff --git a/hall.scm b/hall.scm index f4364f3..4bcc58b 100644 --- a/hall.scm +++ b/hall.scm @@ -55,6 +55,7 @@ "prescheme" ((directory "primop" ((scheme-file "primop"))) (scheme-file "display") + (scheme-file "expand") (scheme-file "form") (scheme-file "front-end") (scheme-file "record") diff --git a/prescheme/scheme48.scm b/prescheme/scheme48.scm index beb4bf2..e81baed 100644 --- a/prescheme/scheme48.scm +++ b/prescheme/scheme48.scm @@ -7,6 +7,7 @@ ;;; scheme48-1.9.2/scheme/big/big-util.scm ;;; scheme48-1.9.2/scheme/big/more-port.scm ;;; scheme48-1.9.2/scheme/rts/exception.scm +;;; scheme48-1.9.2/scheme/rts/util.scm (define-module (prescheme scheme48) #:use-module (ice-9 format) @@ -59,7 +60,8 @@ any? every? filter-map - partition-list) + partition-list + fold) #:re-export (define-enumeration enum name->enumerand @@ -197,3 +199,9 @@ (loop (cdr l) (cons (car l) yes) no)) (else (loop (cdr l) yes (cons (car l) no)))))) + +(define (fold folder list accumulator) + (do ((list list (cdr list)) + (accum accumulator (folder (car list) accum))) + ((null? list) + accum))) diff --git a/ps-compiler/prescheme/expand.scm b/ps-compiler/prescheme/expand.scm new file mode 100644 index 0000000..69c4657 --- /dev/null +++ b/ps-compiler/prescheme/expand.scm @@ -0,0 +1,91 @@ +;;; Ported from Scheme 48 1.9. See file COPYING for notices and license. +;;; +;;; Port Author: Andrew Whatson +;;; +;;; Original Authors: Richard Kelsey +;;; +;;; scheme48-1.9.2/ps-compiler/prescheme/expand.scm +;;; +;;; Expanding using the Scheme 48 expander. + +(define-module (ps-compiler prescheme expand) + #:use-module (prescheme scheme48) + #:use-module (ps-compiler node node) + #:use-module (ps-compiler util util) + #:export (scan-packages)) + +(define (scan-packages packages) + (let ((definitions + (fold (lambda (package definitions) + (let ((cenv (package->environment package))) + (fold (lambda (form definitions) + (let ((node (expand-form form cenv))) + (cond ((define-node? node) + (cons (eval-define (expand node cenv) + cenv) + definitions)) + (else + (eval-node (expand node cenv) + global-ref + global-set! + eval-primitive) + definitions)))) + (call-with-values + (lambda () + (package-source package)) + (lambda (files.forms usual-transforms primitives?) + (scan-forms (apply append (map cdr files.forms)) + cenv))) + definitions))) + packages + '()))) + (reverse (map (lambda (var) + (let ((value (variable-flag var))) + (set-variable-flag! var #f) + (cons var value))) + definitions)))) + +(define package->environment + ;; FIXME: port scheme/bcomp/package.scm + ;; (structure-ref packages package->environment) + ) + +(define define-node? (node-predicate 'define)) + +(define (eval-define node cenv) + (let* ((form (node-form node)) + (value (eval-node (caddr form) + global-ref + global-set! + eval-primitive)) + (lhs (cadr form))) + (global-set! lhs value) + (name->variable-or-value lhs))) + +(define (global-ref name) + (let ((thing (name->variable-or-value name))) + (if (variable? thing) + (variable-flag thing) + thing))) + +(define (global-set! name value) + (let ((thing (name->variable-or-value name))) + (if (primitive? thing) + (bug "trying to set the value of primitive ~S" thing) + (set-variable-flag! thing value)))) + +(define (name->variable-or-value name) + (let ((binding (node-ref name 'binding))) + (if (binding? binding) + (let ((value (binding-place binding)) + (static (binding-static binding))) + (cond ((primitive? static) + static) + ((variable? value) + value) + ((and (location? value) + (constant? (contents value))) + (contents value)) + (else + (bug "global binding is not a variable, primitive or constant ~S" name)))) + (user-error "unbound variable ~S" (node-form name)))))