Stub prescheme expand package

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

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")

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

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