Stub prescheme expand package
This commit is contained in:
parent
21aa17d6bc
commit
d7545b6970
3
TODO.org
3
TODO.org
|
@ -77,7 +77,7 @@ involve:
|
||||||
*** [X] protocol
|
*** [X] protocol
|
||||||
*** [-] prescheme-front-end
|
*** [-] prescheme-front-end
|
||||||
*** [-] forms
|
*** [-] forms
|
||||||
*** [ ] expand
|
*** [-] expand
|
||||||
*** [ ] ps-primitives
|
*** [ ] ps-primitives
|
||||||
*** [ ] primitive-data
|
*** [ ] primitive-data
|
||||||
*** [ ] eval-node
|
*** [ ] eval-node
|
||||||
|
@ -102,6 +102,7 @@ involve:
|
||||||
|
|
||||||
** TODO port scheme/bcomp/node.scm
|
** TODO port scheme/bcomp/node.scm
|
||||||
** TODO port scheme/bcomp/schemify.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 port write-one-line from scheme/big/more-port.scm
|
||||||
|
|
||||||
* TODO prepare some compatibility tests
|
* TODO prepare some compatibility tests
|
||||||
|
|
1
hall.scm
1
hall.scm
|
@ -55,6 +55,7 @@
|
||||||
"prescheme"
|
"prescheme"
|
||||||
((directory "primop" ((scheme-file "primop")))
|
((directory "primop" ((scheme-file "primop")))
|
||||||
(scheme-file "display")
|
(scheme-file "display")
|
||||||
|
(scheme-file "expand")
|
||||||
(scheme-file "form")
|
(scheme-file "form")
|
||||||
(scheme-file "front-end")
|
(scheme-file "front-end")
|
||||||
(scheme-file "record")
|
(scheme-file "record")
|
||||||
|
|
|
@ -7,6 +7,7 @@
|
||||||
;;; scheme48-1.9.2/scheme/big/big-util.scm
|
;;; scheme48-1.9.2/scheme/big/big-util.scm
|
||||||
;;; scheme48-1.9.2/scheme/big/more-port.scm
|
;;; scheme48-1.9.2/scheme/big/more-port.scm
|
||||||
;;; scheme48-1.9.2/scheme/rts/exception.scm
|
;;; scheme48-1.9.2/scheme/rts/exception.scm
|
||||||
|
;;; scheme48-1.9.2/scheme/rts/util.scm
|
||||||
|
|
||||||
(define-module (prescheme scheme48)
|
(define-module (prescheme scheme48)
|
||||||
#:use-module (ice-9 format)
|
#:use-module (ice-9 format)
|
||||||
|
@ -59,7 +60,8 @@
|
||||||
any?
|
any?
|
||||||
every?
|
every?
|
||||||
filter-map
|
filter-map
|
||||||
partition-list)
|
partition-list
|
||||||
|
fold)
|
||||||
#:re-export (define-enumeration
|
#:re-export (define-enumeration
|
||||||
enum
|
enum
|
||||||
name->enumerand
|
name->enumerand
|
||||||
|
@ -197,3 +199,9 @@
|
||||||
(loop (cdr l) (cons (car l) yes) no))
|
(loop (cdr l) (cons (car l) yes) no))
|
||||||
(else
|
(else
|
||||||
(loop (cdr l) yes (cons (car l) no))))))
|
(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)))
|
||||||
|
|
91
ps-compiler/prescheme/expand.scm
Normal file
91
ps-compiler/prescheme/expand.scm
Normal file
|
@ -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)))))
|
Loading…
Reference in a new issue