Moving unit system from mzscheme->scheme/base, reformatting and small changes
as necessary. Ran the quiet testsuite, unit tests, and setup-plt, all good. svn: r17582 original commit: 73d68593af6b7c3a389013527f9b2a46618d1642
This commit is contained in:
parent
bb3d45340d
commit
e19d7a7128
|
@ -1,36 +1,35 @@
|
|||
#lang scheme/base
|
||||
|
||||
(module unitidmap mzscheme
|
||||
;; Help Desk binding info:
|
||||
(define (binding binder bound stx)
|
||||
stx
|
||||
;; This 'bound-in-source is no longer needed
|
||||
#;
|
||||
(syntax-property
|
||||
stx
|
||||
'bound-in-source
|
||||
(cons binder (syntax-local-introduce bound))))
|
||||
|
||||
;; Help Desk binding info:
|
||||
(define (binding binder bound stx)
|
||||
stx
|
||||
;; This 'bound-in-source is no longer needed
|
||||
#;
|
||||
(syntax-property
|
||||
stx
|
||||
'bound-in-source
|
||||
(cons binder (syntax-local-introduce bound))))
|
||||
(define (make-id-mapper unbox-stx the-binder)
|
||||
(let ([set!-stx (datum->syntax unbox-stx 'set! #f)])
|
||||
(make-set!-transformer
|
||||
(lambda (sstx)
|
||||
(cond
|
||||
[(identifier? sstx)
|
||||
(binding the-binder sstx
|
||||
unbox-stx)]
|
||||
[(free-identifier=? set!-stx (car (syntax-e sstx)))
|
||||
(raise-syntax-error
|
||||
'unit
|
||||
"cannot set! imported or exported variables"
|
||||
sstx)]
|
||||
[else
|
||||
(binding
|
||||
the-binder (car (syntax-e sstx))
|
||||
(datum->syntax
|
||||
sstx
|
||||
(cons unbox-stx (cdr (syntax-e sstx)))
|
||||
sstx))])))))
|
||||
|
||||
(define (make-id-mapper unbox-stx the-binder)
|
||||
(let ([set!-stx (datum->syntax-object unbox-stx 'set! #f)])
|
||||
(make-set!-transformer
|
||||
(lambda (sstx)
|
||||
(cond
|
||||
[(identifier? sstx)
|
||||
(binding the-binder sstx
|
||||
unbox-stx)]
|
||||
[(module-identifier=? set!-stx (car (syntax-e sstx)))
|
||||
(raise-syntax-error
|
||||
'unit
|
||||
"cannot set! imported or exported variables"
|
||||
sstx)]
|
||||
[else
|
||||
(binding
|
||||
the-binder (car (syntax-e sstx))
|
||||
(datum->syntax-object
|
||||
sstx
|
||||
(cons unbox-stx (cdr (syntax-e sstx)))
|
||||
sstx))])))))
|
||||
|
||||
(provide make-id-mapper))
|
||||
(provide make-id-mapper)
|
||||
|
||||
|
|
|
@ -1,26 +1,27 @@
|
|||
(module unit-exptime mzscheme
|
||||
(require "private/unit-syntax.ss"
|
||||
"private/unit-compiletime.ss")
|
||||
#lang scheme/base
|
||||
|
||||
(provide unit-static-signatures
|
||||
signature-members)
|
||||
(require "private/unit-syntax.ss"
|
||||
"private/unit-compiletime.ss")
|
||||
|
||||
(define (unit-static-signatures name err-stx)
|
||||
(parameterize ((error-syntax err-stx))
|
||||
(let ((ui (lookup-def-unit name)))
|
||||
(values (apply list (unit-info-import-sig-ids ui))
|
||||
(apply list (unit-info-export-sig-ids ui))))))
|
||||
(provide unit-static-signatures
|
||||
signature-members)
|
||||
|
||||
(define (signature-members name err-stx)
|
||||
(parameterize ((error-syntax err-stx))
|
||||
(let ([s (lookup-signature name)])
|
||||
(values
|
||||
;; extends:
|
||||
(and (pair? (cdr (siginfo-names (signature-siginfo s))))
|
||||
(cadr (siginfo-names (signature-siginfo s))))
|
||||
;; vars
|
||||
(apply list (signature-vars s))
|
||||
;; defined vars
|
||||
(apply list (apply append (map car (signature-val-defs s))))
|
||||
;; defined stxs
|
||||
(apply list (apply append (map car (signature-stx-defs s)))))))))
|
||||
(define (unit-static-signatures name err-stx)
|
||||
(parameterize ((error-syntax err-stx))
|
||||
(let ((ui (lookup-def-unit name)))
|
||||
(values (apply list (unit-info-import-sig-ids ui))
|
||||
(apply list (unit-info-export-sig-ids ui))))))
|
||||
|
||||
(define (signature-members name err-stx)
|
||||
(parameterize ((error-syntax err-stx))
|
||||
(let ([s (lookup-signature name)])
|
||||
(values
|
||||
;; extends:
|
||||
(and (pair? (cdr (siginfo-names (signature-siginfo s))))
|
||||
(cadr (siginfo-names (signature-siginfo s))))
|
||||
;; vars
|
||||
(apply list (signature-vars s))
|
||||
;; defined vars
|
||||
(apply list (apply append (map car (signature-val-defs s))))
|
||||
;; defined stxs
|
||||
(apply list (apply append (map car (signature-stx-defs s))))))))
|
||||
|
|
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user