~ chicken-core (chicken-5) cfc05f5fbd419de5e4c66c7ada8226bcf556ebf7
commit cfc05f5fbd419de5e4c66c7ada8226bcf556ebf7
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Sep 6 12:35:28 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Tue Sep 6 12:35:28 2011 +0200
restore interface defs in modules, added define-type (untested)
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index c9ba3428..3d2f3ba8 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1109,23 +1109,25 @@
'define-interface '()
(##sys#er-transformer
(lambda (x r c)
- (##sys#check-syntax 'define-interface x '(_ symbol _))
+ (##sys#check-syntax 'define-interface x '(_ variable _))
(let ((name (##sys#strip-syntax (cadr x)))
(%quote (r 'quote)))
(when (eq? '* name)
(syntax-error-hook
'define-interface "`*' is not allowed as a name for an interface"))
`(,(r 'begin-for-syntax)
- (##sys#register-interface
+ (##sys#put/restore!
(,%quote ,name)
- (,%quote ,(let ((exps (##sys#strip-syntax (caddr x))))
- (cond ((eq? '* exps) '*)
- ((symbol? exps) `(#:interface ,exps))
- ((list? exps)
- (##sys#validate-exports exps 'define-interface))
- (else
- (syntax-error-hook
- 'define-interface "invalid exports" (caddr x))))))))))))
+ (,%quote ##core#interface)
+ (,%quote
+ ,(let ((exps (##sys#strip-syntax (caddr x))))
+ (cond ((eq? '* exps) '*)
+ ((symbol? exps) `(#:interface ,exps))
+ ((list? exps)
+ (##sys#validate-exports exps 'define-interface))
+ (else
+ (syntax-error-hook
+ 'define-interface "invalid exports" (caddr x))))))))))))
;;; functor definition
@@ -1281,6 +1283,26 @@
(list (car clause) `(##core#begin ,@(cdr clause))))
(cddr x))))))))
+(##sys#extend-macro-environment
+ 'define-type '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (##sys#check-syntax 'define-type x '(_ variable _))
+ (cond ((memq #:csi ##sys#features) '(##core#undefined))
+ (else
+ (let ((name (##sys#strip-syntax (cadr x)))
+ (%quote (r 'quote))
+ (t0 (##sys#strip-syntax (caddr x))))
+ (let-values (((t pred pure) (##compiler#validate-type t0 #f)))
+ (if t
+ `(,(r 'begin-for-syntax)
+ (##sys#put/restore!
+ (,%quote ,name)
+ (,%quote '##compiler#type-abbreviation)
+ (,%quote ,t)))
+ (syntax-error-hook 'define-type "invalid type" name t0)))))))))
+
+
;; capture current macro env
diff --git a/compiler.scm b/compiler.scm
index a68b01fa..92529ce4 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -851,43 +851,45 @@
##sys#initial-macro-environment)
(##sys#module-alias-environment
(##sys#module-alias-environment)))
- (let loop ((body (cdddr x)) (xs '()))
- (cond
- ((null? body)
- (handle-exceptions ex
- (begin
- ;; avoid backtrace
- (print-error-message ex (current-error-port))
- (exit 1))
- (##sys#finalize-module (##sys#current-module)))
- (cond ((or all-import-libraries
- (assq name import-libraries) ) =>
- (lambda (il)
- (when enable-module-registration
- (emit-import-lib name il))
- (values
- (reverse xs)
- '((##core#undefined)))))
- ((not enable-module-registration)
- (values
- (reverse xs)
- '((##core#undefined))))
- (else
- (values
- (reverse xs)
- (if standalone-executable
- '()
- (##sys#compiled-module-registration
- (##sys#current-module)))))))
- (else
- (loop
- (cdr body)
- (cons (walk
- (car body)
- e ;?
- (##sys#current-environment)
- #f #f h)
- xs))))))))
+ (##sys#with-property-restore
+ (lambda ()
+ (let loop ((body (cdddr x)) (xs '()))
+ (cond
+ ((null? body)
+ (handle-exceptions ex
+ (begin
+ ;; avoid backtrace
+ (print-error-message ex (current-error-port))
+ (exit 1))
+ (##sys#finalize-module (##sys#current-module)))
+ (cond ((or all-import-libraries
+ (assq name import-libraries) ) =>
+ (lambda (il)
+ (when enable-module-registration
+ (emit-import-lib name il))
+ (values
+ (reverse xs)
+ '((##core#undefined)))))
+ ((not enable-module-registration)
+ (values
+ (reverse xs)
+ '((##core#undefined))))
+ (else
+ (values
+ (reverse xs)
+ (if standalone-executable
+ '()
+ (##sys#compiled-module-registration
+ (##sys#current-module)))))))
+ (else
+ (loop
+ (cdr body)
+ (cons (walk
+ (car body)
+ e ;?
+ (##sys#current-environment)
+ #f #f h)
+ xs))))))))))
(let ((body
(canonicalize-begin-body
(append
@@ -898,7 +900,7 @@
(lambda (x)
(walk
x
- e ;?
+ e ;?
(##sys#current-meta-environment) #f #f h) )
mreg))
body))))
diff --git a/eval.scm b/eval.scm
index 4b8b8fe1..445df6e7 100644
--- a/eval.scm
+++ b/eval.scm
@@ -623,27 +623,29 @@
##sys#initial-macro-environment)
(##sys#module-alias-environment
(##sys#module-alias-environment)))
- (let loop ((body (cdddr x)) (xs '()))
- (if (null? body)
- (let ((xs (reverse xs)))
- (##sys#finalize-module (##sys#current-module))
- (lambda (v)
- (let loop2 ((xs xs))
- (if (null? xs)
- (##sys#void)
- (let ((n (cdr xs)))
- (cond ((pair? n)
- ((car xs) v)
- (loop2 n))
- (else
- ((car xs) v))))))))
- (loop
- (cdr body)
- (cons (compile
- (car body)
- '() #f tf cntr
- (##sys#current-environment))
- xs))))) ) )
+ (##sys#with-property-restore
+ (lambda ()
+ (let loop ((body (cdddr x)) (xs '()))
+ (if (null? body)
+ (let ((xs (reverse xs)))
+ (##sys#finalize-module (##sys#current-module))
+ (lambda (v)
+ (let loop2 ((xs xs))
+ (if (null? xs)
+ (##sys#void)
+ (let ((n (cdr xs)))
+ (cond ((pair? n)
+ ((car xs) v)
+ (loop2 n))
+ (else
+ ((car xs) v))))))))
+ (loop
+ (cdr body)
+ (cons (compile
+ (car body)
+ '() #f tf cntr
+ (##sys#current-environment))
+ xs))))) ) )))
[(##core#loop-lambda)
(compile `(,(rename 'lambda se) ,@(cdr x)) e #f tf cntr se) ]
@@ -823,6 +825,33 @@
x
env) )
+
+;;; Setting properties dynamically scroped
+
+(define-values (##sys#put/restore! ##sys#with-property-restore)
+ (let ((trail '())
+ (restoring #f))
+ (values
+ (lambda (sym prop val)
+ (when restoring
+ (set! trail (cons (list sym prop (##sys#get sym prop)) trail)))
+ (##sys#put! sym prop val)
+ val)
+ (lambda (thunk)
+ (let ((t0 #f)
+ (r0 restoring))
+ (dynamic-wind
+ (lambda ()
+ (set! t0 trail)
+ (set! restoring #t))
+ thunk
+ (lambda ()
+ (do () ((eq? t0 trail))
+ (apply ##sys#put! (car trail))
+ (set! trail (cdr trail)))
+ (set! restoring r0))))))))
+
+
;;; Split lambda-list into its parts:
(define ##sys#decompose-lambda-list
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 9bd214d3..72b4b8d6 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -89,6 +89,7 @@
; ##compiler#enforce -> BOOL
; ##compiler#special-result-type -> PROCEDURE
; ##compiler#escape -> #f | 'yes | 'no
+; ##compiler#type-abbreviation -> TYPESPEC
;
; specialization specifiers:
;
@@ -1786,6 +1787,7 @@
;; - simplifies result
;; - coalesces all "forall" forms into one (remove "forall" if typevar-set is empty)
;; - renames type-variables
+ ;; - replaces type-abbreviations
(let ((ptype #f) ; (T . PT) | #f
(clean #f)
(typevars '())
@@ -1827,6 +1829,7 @@
'(or eof null fixnum char boolean))
((eq? t 'any) '*)
((eq? t 'void) 'undefined)
+ ((##sys#get t '##compiler#type-abbreviation) => cdr)
((not (pair? t))
(cond ((memq t typevars) t)
(else #f)))
Trap