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:
Stevie Strickland 2010-01-08 21:44:42 +00:00
parent bb3d45340d
commit e19d7a7128
3 changed files with 1936 additions and 1937 deletions

View File

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

View File

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