Stub prescheme front-end package
This commit is contained in:
parent
c84c492567
commit
688a1fe410
2
TODO.org
2
TODO.org
|
@ -75,7 +75,7 @@ involve:
|
|||
*** [-] prescheme-compiler
|
||||
*** [-] prescheme-display
|
||||
*** [X] protocol
|
||||
*** [ ] prescheme-front-end
|
||||
*** [-] prescheme-front-end
|
||||
*** [ ] forms
|
||||
*** [ ] expand
|
||||
*** [ ] ps-primitives
|
||||
|
|
1
hall.scm
1
hall.scm
|
@ -55,6 +55,7 @@
|
|||
"prescheme"
|
||||
((directory "primop" ((scheme-file "primop")))
|
||||
(scheme-file "display")
|
||||
(scheme-file "front-end")
|
||||
(scheme-file "record")
|
||||
(scheme-file "spec")
|
||||
(scheme-file "top")
|
||||
|
|
146
ps-compiler/prescheme/front-end.scm
Normal file
146
ps-compiler/prescheme/front-end.scm
Normal file
|
@ -0,0 +1,146 @@
|
|||
;;; 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/front-end.scm
|
||||
|
||||
(define-module (ps-compiler prescheme front-end)
|
||||
#:use-module (prescheme scheme48)
|
||||
#:use-module (ps-compiler node node)
|
||||
#:use-module (ps-compiler prescheme type)
|
||||
#:use-module (ps-compiler prescheme type-scheme)
|
||||
#:use-module (ps-compiler util util)
|
||||
#:export (prescheme-front-end))
|
||||
|
||||
(define (prescheme-front-end package-ids spec-files copy no-copy shadow)
|
||||
(receive (packages exports lookup)
|
||||
(package-specs->packages+exports package-ids spec-files)
|
||||
(let ((forms (flatten-definitions (scan-packages packages))))
|
||||
(annotate-forms! (car package-ids) lookup exports copy no-copy shadow)
|
||||
(receive (forms producer)
|
||||
(sort-forms forms)
|
||||
(format #t "Checking types~%")
|
||||
(let ((sorted (let loop ((forms '()))
|
||||
(cond ((producer)
|
||||
=> (lambda (f)
|
||||
(type-check-form f)
|
||||
(loop (cons f forms))))
|
||||
(else
|
||||
(reverse forms))))))
|
||||
;; (format #t "Adding coercions~%")
|
||||
;; (add-type-coercions (form-reducer forms))
|
||||
sorted)))))
|
||||
|
||||
(define (form-reducer forms)
|
||||
(lambda (proc init)
|
||||
(let loop ((forms forms) (value init))
|
||||
(if (null? forms)
|
||||
value
|
||||
(loop (cdr forms)
|
||||
(proc (form-name (car forms))
|
||||
(form-value (car forms))
|
||||
value))))))
|
||||
|
||||
(define (test id files)
|
||||
((structure-ref node reset-node-id))
|
||||
((structure-ref record-types reset-record-data!))
|
||||
(prescheme-front-end id files '() '() '()))
|
||||
|
||||
(define (annotate-forms! package-id lookup exports copy no-copy shadow)
|
||||
(mark-forms! exports
|
||||
lookup
|
||||
(lambda (f) (set-form-exported?! f #t))
|
||||
"exported")
|
||||
(mark-forms! copy
|
||||
lookup
|
||||
(lambda (f) (set-form-integrate! f 'yes))
|
||||
"to be copied")
|
||||
(mark-forms! no-copy
|
||||
lookup
|
||||
(lambda (f) (set-form-integrate! f 'no))
|
||||
"not to be copied")
|
||||
(for-each (lambda (data)
|
||||
(let ((owner (package-lookup lookup (caar data) (cadar data))))
|
||||
(if owner
|
||||
(mark-forms! (cdr data)
|
||||
lookup
|
||||
(lambda (f)
|
||||
(set-form-shadowed! owner
|
||||
(cons (form-var f)
|
||||
(form-shadowed owner))))
|
||||
(format #f "shadowed in ~S" (car data)))
|
||||
(format #t "Warning: no definition for ~S, cannot shadow ~S~%"
|
||||
(car data) (cdr data)))))
|
||||
shadow))
|
||||
|
||||
(define (mark-forms! specs lookup marker mark)
|
||||
(let ((lose (lambda (p n)
|
||||
(format #t "Warning: no definition for ~S, cannot mark as ~A~%"
|
||||
(list p n) mark))))
|
||||
(for-each (lambda (spec)
|
||||
(let ((package-id (car spec))
|
||||
(ids (cdr spec)))
|
||||
(for-each (lambda (id)
|
||||
(cond ((package-lookup lookup package-id id)
|
||||
=> marker)
|
||||
(else
|
||||
(lose package-id id))))
|
||||
ids)))
|
||||
specs)))
|
||||
|
||||
(define (package-lookup lookup package-id id)
|
||||
(let ((var (lookup package-id id)))
|
||||
(and (variable? var)
|
||||
(maybe-variable->form var))))
|
||||
|
||||
;; Two possibilities:
|
||||
;; 1. The variable is settable but the thunk gives it no particular value.
|
||||
;; 2. A real value is or needs to be present, so we relate the type of
|
||||
;; the variable with the type of the value.
|
||||
|
||||
;; thunk's value may be a STOB and not a lambda.
|
||||
|
||||
(define (type-check-form form)
|
||||
;; (format #t " ~S: " (variable-name (form-var form)))
|
||||
(let* ((value (form-value form))
|
||||
(var (form-var form))
|
||||
(name (form-name form))
|
||||
(value-type (cond (((structure-ref nodes node?) value)
|
||||
(infer-definition-type value (source-proc form)))
|
||||
((variable? value)
|
||||
(get-package-variable-type value))
|
||||
(else
|
||||
(bug "unknown kind of form value ~S" value)))))
|
||||
(set-form-value-type! form value-type)
|
||||
(cond ((not (variable-set!? var))
|
||||
(let ((type (cond ((eq? type/unknown (variable-type var))
|
||||
(let ((type (schemify-type value-type 0)))
|
||||
(set-variable-type! var type)
|
||||
type))
|
||||
(else
|
||||
(unify! value-type (get-package-variable-type var) form)
|
||||
value-type))))
|
||||
(if (not (type-scheme? type))
|
||||
(make-nonpolymorphic! type)) ;; lock down any related uvars
|
||||
;;(format #t "~S~%" (instantiate type))
|
||||
))
|
||||
((not (or (eq? type/unit value-type)
|
||||
(eq? type/null value-type)))
|
||||
(make-nonpolymorphic! value-type) ; no polymorphism allowed (so it
|
||||
;; is not checked for, so there may be depth 0 uvars in the type)
|
||||
;; (format #t " ~S~%" (instantiate value-type))
|
||||
(unify! value-type (get-package-variable-type var) form))
|
||||
((eq? type/unknown (variable-type var))
|
||||
(get-package-variable-type var)))))
|
||||
|
||||
(define (source-proc form)
|
||||
(lambda (port)
|
||||
(write-one-line port
|
||||
70
|
||||
(lambda (port)
|
||||
(format port "~S = ~S"
|
||||
(form-name form)
|
||||
((structure-ref nodes schemify)
|
||||
(form-value form)))))))
|
|
@ -19,6 +19,7 @@
|
|||
#:use-module (ps-compiler node node-util)
|
||||
#:use-module (ps-compiler node primop)
|
||||
#:use-module (ps-compiler param)
|
||||
#:use-module (ps-compiler prescheme front-end)
|
||||
#:use-module (ps-compiler prescheme record)
|
||||
#:use-module (ps-compiler prescheme type)
|
||||
#:use-module (ps-compiler prescheme type-scheme)
|
||||
|
|
Loading…
Reference in a new issue