TakeV/guile-prescheme
Archived
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Stub prescheme expand package

Browse source
This commit is contained in:
Andrew Whatson 2022-08-11 20:16:03 +10:00
parent 21aa17d6bc
commit d7545b6970
4 changed files with 103 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
TODO.org
View file

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

1
hall.scm
View file

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

10
prescheme/scheme48.scm
View file

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

91
ps-compiler/prescheme/expand.scm Normal file
View 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)))))