~ chicken-core (chicken-5) 33d9c24469ce00b00f453ac5c4285f8a52a9cb1a
commit 33d9c24469ce00b00f453ac5c4285f8a52a9cb1a
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Mon Sep 11 08:41:41 2017 +1200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Mon Sep 11 18:51:59 2017 +0200
Add "chicken.type" module
This moves the type-related macros in chicken-syntax.scm upwards in the
file and captures a syntax environment containing just those six forms.
These are added to a new "chicken.type" module defined in module.scm. We
also leave these macros in the bare "chicken" module for the time being,
as we have done with the "chicken.condition" module.
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/README b/README
index 251debe8..6ee15437 100644
--- a/README
+++ b/README
@@ -326,6 +326,7 @@ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/
| | |-- chicken.tcp.import.so
| | |-- chicken.time.import.so
| | |-- chicken.time.posix.import.so
+ | | |-- chicken.type.import.so
| | |-- modules.db
| | |-- srfi-4.import.so
| | `-- types.db
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index e3a2fe11..c951d467 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -45,7 +45,7 @@
(include "mini-srfi-1.scm")
;;; Exceptions:
-(define ##sys#chicken.condition-macro-environment
+(set! ##sys#chicken.condition-macro-environment
(let ((me0 (##sys#macro-environment)))
(##sys#extend-macro-environment
@@ -106,6 +106,161 @@
(##sys#macro-subset me0 ##sys#default-macro-environment)))
+
+;;; type-related syntax
+
+(set! ##sys#chicken.type-macro-environment
+ (let ((me0 (##sys#macro-environment)))
+
+(##sys#extend-macro-environment
+ ': '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (##sys#check-syntax ': x '(_ symbol _ . _))
+ (if (not (memq #:compiling ##sys#features))
+ '(##core#undefined)
+ (let* ((type1 (chicken.syntax#strip-syntax (caddr x)))
+ (name1 (cadr x)))
+ ;; we need pred/pure info, so not using
+ ;; "chicken.compiler.scrutinizer#check-and-validate-type"
+ (let-values (((type pred pure)
+ (chicken.compiler.scrutinizer#validate-type
+ type1
+ (chicken.syntax#strip-syntax name1))))
+ (cond ((not type)
+ (chicken.syntax#syntax-error ': "invalid type syntax" name1 type1))
+ (else
+ `(##core#declare
+ (type (,name1 ,type1 ,@(cdddr x)))
+ ,@(if pure `((pure ,name1)) '())
+ ,@(if pred `((predicate (,name1 ,pred))) '()))))))))))
+
+(##sys#extend-macro-environment
+ 'the '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (##sys#check-syntax 'the x '(_ _ _))
+ (if (not (memq #:compiling ##sys#features))
+ (caddr x)
+ `(##core#the ,(chicken.compiler.scrutinizer#check-and-validate-type (cadr x) 'the)
+ #t
+ ,(caddr x))))))
+
+(##sys#extend-macro-environment
+ 'assume '()
+ (syntax-rules ()
+ ((_ ((var type) ...) body ...)
+ (let ((var (the type var)) ...) body ...))))
+
+(##sys#extend-macro-environment
+ 'define-specialization '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (cond ((not (memq #:compiling ##sys#features)) '(##core#undefined))
+ (else
+ (##sys#check-syntax 'define-specialization x '(_ (variable . #(_ 0)) _ . #(_ 0 1)))
+ (let* ((head (cadr x))
+ (name (car head))
+ (gname (##sys#globalize name '())) ;XXX correct?
+ (args (cdr head))
+ (alias (gensym name))
+ (galias (##sys#globalize alias '())) ;XXX and this?
+ (rtypes (and (pair? (cdddr x)) (chicken.syntax#strip-syntax (caddr x))))
+ (%define (r 'define))
+ (body (if rtypes (cadddr x) (caddr x))))
+ (let loop ((args args) (anames '()) (atypes '()))
+ (cond ((null? args)
+ (let ((anames (reverse anames))
+ (atypes (reverse atypes))
+ (spec
+ `(,galias ,@(let loop2 ((anames anames) (i 1))
+ (if (null? anames)
+ '()
+ (cons (vector i)
+ (loop2 (cdr anames) (fx+ i 1))))))))
+ (##sys#put!
+ gname '##compiler#local-specializations
+ (##sys#append
+ (##sys#get gname '##compiler#local-specializations '())
+ (list
+ (cons atypes
+ (if (and rtypes (pair? rtypes))
+ (list
+ (map (cut chicken.compiler.scrutinizer#check-and-validate-type
+ <>
+ 'define-specialization)
+ rtypes)
+ spec)
+ (list spec))))))
+ `(##core#begin
+ (##core#declare (inline ,alias) (hide ,alias))
+ (,%define (,alias ,@anames)
+ (##core#let ,(map (lambda (an at)
+ (list an `(##core#the ,at #t ,an)))
+ anames atypes)
+ ,body)))))
+ (else
+ (let ((arg (car args)))
+ (cond ((symbol? arg)
+ (loop (cdr args) (cons arg anames) (cons '* atypes)))
+ ((and (list? arg) (fx= 2 (length arg)) (symbol? (car arg)))
+ (loop
+ (cdr args)
+ (cons (car arg) anames)
+ (cons
+ (chicken.compiler.scrutinizer#check-and-validate-type
+ (cadr arg)
+ 'define-specialization)
+ atypes)))
+ (else (chicken.syntax#syntax-error
+ 'define-specialization
+ "invalid argument syntax" arg head)))))))))))))
+
+(##sys#extend-macro-environment
+ 'compiler-typecase '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (##sys#check-syntax 'compiler-typecase x '(_ _ . #((_ . #(_ 1)) 1)))
+ (let ((val (memq #:compiling ##sys#features))
+ (var (gensym))
+ (ln (chicken.syntax#get-line-number x)))
+ `(##core#let ((,var ,(cadr x)))
+ (##core#typecase
+ ,ln
+ ,var ; must be variable (see: CPS transform)
+ ,@(map (lambda (clause)
+ (let ((hd (chicken.syntax#strip-syntax (car clause))))
+ (list
+ (if (eq? hd 'else)
+ 'else
+ (if val
+ (chicken.compiler.scrutinizer#check-and-validate-type
+ hd
+ 'compiler-typecase)
+ hd))
+ `(##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 ((not (memq #:compiling ##sys#features)) '(##core#undefined))
+ (else
+ (let ((name (chicken.syntax#strip-syntax (cadr x)))
+ (%quote (r 'quote))
+ (t0 (chicken.syntax#strip-syntax (caddr x))))
+ `(##core#elaborationtimeonly
+ (##sys#put/restore!
+ (,%quote ,name)
+ (,%quote ##compiler#type-abbreviation)
+ (,%quote
+ ,(chicken.compiler.scrutinizer#check-and-validate-type
+ t0 'define-type name))))))))))
+
+(##sys#macro-subset me0 ##sys#default-macro-environment)))
+
;;; Other non-standard macros:
(define ##sys#chicken-macro-environment
@@ -1167,161 +1322,12 @@
(##core#let-compiler-syntax (binding ...) body ...))))
-;;; type-related syntax
-
-(##sys#extend-macro-environment
- ': '()
- (##sys#er-transformer
- (lambda (x r c)
- (##sys#check-syntax ': x '(_ symbol _ . _))
- (if (not (memq #:compiling ##sys#features))
- '(##core#undefined)
- (let* ((type1 (chicken.syntax#strip-syntax (caddr x)))
- (name1 (cadr x)))
- ;; we need pred/pure info, so not using
- ;; "chicken.compiler.scrutinizer#check-and-validate-type"
- (let-values (((type pred pure)
- (chicken.compiler.scrutinizer#validate-type
- type1
- (chicken.syntax#strip-syntax name1))))
- (cond ((not type)
- (chicken.syntax#syntax-error ': "invalid type syntax" name1 type1))
- (else
- `(##core#declare
- (type (,name1 ,type1 ,@(cdddr x)))
- ,@(if pure `((pure ,name1)) '())
- ,@(if pred `((predicate (,name1 ,pred))) '()))))))))))
-
-(##sys#extend-macro-environment
- 'the '()
- (##sys#er-transformer
- (lambda (x r c)
- (##sys#check-syntax 'the x '(_ _ _))
- (if (not (memq #:compiling ##sys#features))
- (caddr x)
- `(##core#the ,(chicken.compiler.scrutinizer#check-and-validate-type (cadr x) 'the)
- #t
- ,(caddr x))))))
-
-(##sys#extend-macro-environment
- 'assume '()
- (syntax-rules ()
- ((_ ((var type) ...) body ...)
- (let ((var (the type var)) ...) body ...))))
-
-(##sys#extend-macro-environment
- 'define-specialization '()
- (##sys#er-transformer
- (lambda (x r c)
- (cond ((not (memq #:compiling ##sys#features)) '(##core#undefined))
- (else
- (##sys#check-syntax 'define-specialization x '(_ (variable . #(_ 0)) _ . #(_ 0 1)))
- (let* ((head (cadr x))
- (name (car head))
- (gname (##sys#globalize name '())) ;XXX correct?
- (args (cdr head))
- (alias (gensym name))
- (galias (##sys#globalize alias '())) ;XXX and this?
- (rtypes (and (pair? (cdddr x)) (chicken.syntax#strip-syntax (caddr x))))
- (%define (r 'define))
- (body (if rtypes (cadddr x) (caddr x))))
- (let loop ((args args) (anames '()) (atypes '()))
- (cond ((null? args)
- (let ((anames (reverse anames))
- (atypes (reverse atypes))
- (spec
- `(,galias ,@(let loop2 ((anames anames) (i 1))
- (if (null? anames)
- '()
- (cons (vector i)
- (loop2 (cdr anames) (fx+ i 1))))))))
- (##sys#put!
- gname '##compiler#local-specializations
- (##sys#append
- (##sys#get gname '##compiler#local-specializations '())
- (list
- (cons atypes
- (if (and rtypes (pair? rtypes))
- (list
- (map (cut chicken.compiler.scrutinizer#check-and-validate-type
- <>
- 'define-specialization)
- rtypes)
- spec)
- (list spec))))))
- `(##core#begin
- (##core#declare (inline ,alias) (hide ,alias))
- (,%define (,alias ,@anames)
- (##core#let ,(map (lambda (an at)
- (list an `(##core#the ,at #t ,an)))
- anames atypes)
- ,body)))))
- (else
- (let ((arg (car args)))
- (cond ((symbol? arg)
- (loop (cdr args) (cons arg anames) (cons '* atypes)))
- ((and (list? arg) (fx= 2 (length arg)) (symbol? (car arg)))
- (loop
- (cdr args)
- (cons (car arg) anames)
- (cons
- (chicken.compiler.scrutinizer#check-and-validate-type
- (cadr arg)
- 'define-specialization)
- atypes)))
- (else (chicken.syntax#syntax-error
- 'define-specialization
- "invalid argument syntax" arg head)))))))))))))
-
-(##sys#extend-macro-environment
- 'compiler-typecase '()
- (##sys#er-transformer
- (lambda (x r c)
- (##sys#check-syntax 'compiler-typecase x '(_ _ . #((_ . #(_ 1)) 1)))
- (let ((val (memq #:compiling ##sys#features))
- (var (gensym))
- (ln (chicken.syntax#get-line-number x)))
- `(##core#let ((,var ,(cadr x)))
- (##core#typecase
- ,ln
- ,var ; must be variable (see: CPS transform)
- ,@(map (lambda (clause)
- (let ((hd (chicken.syntax#strip-syntax (car clause))))
- (list
- (if (eq? hd 'else)
- 'else
- (if val
- (chicken.compiler.scrutinizer#check-and-validate-type
- hd
- 'compiler-typecase)
- hd))
- `(##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 ((not (memq #:compiling ##sys#features)) '(##core#undefined))
- (else
- (let ((name (chicken.syntax#strip-syntax (cadr x)))
- (%quote (r 'quote))
- (t0 (chicken.syntax#strip-syntax (caddr x))))
- `(##core#elaborationtimeonly
- (##sys#put/restore!
- (,%quote ,name)
- (,%quote ##compiler#type-abbreviation)
- (,%quote
- ,(chicken.compiler.scrutinizer#check-and-validate-type
- t0 'define-type name))))))))))
-
-
;; capture current macro env and add all the preceding ones as well
-(let ((me* (##sys#macro-subset me0 ##sys#default-macro-environment)))
- ;; TODO: omit `chicken.condition-m-e' when plain "chicken" module goes away
- (append ##sys#chicken.condition-macro-environment me*))))
+;; TODO: omit `chicken.{condition,type}-m-e' when plain "chicken" module goes away
+(append ##sys#chicken.condition-macro-environment
+ ##sys#chicken.type-macro-environment
+ (##sys#macro-subset me0 ##sys#default-macro-environment))))
;; register features
diff --git a/distribution/manifest b/distribution/manifest
index 55d86ed0..7e4436f2 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -348,6 +348,8 @@ chicken.time.import.scm
chicken.time.import.c
chicken.time.posix.import.scm
chicken.time.posix.import.c
+chicken.type.import.scm
+chicken.type.import.c
srfi-4.import.scm
srfi-4.import.c
chicken-status.scm
diff --git a/expand.scm b/expand.scm
index d405656e..9e51a41c 100644
--- a/expand.scm
+++ b/expand.scm
@@ -173,6 +173,7 @@
(define ##sys#chicken-macro-environment '()) ; used later in chicken.import.scm
(define ##sys#chicken-ffi-macro-environment '()) ; used later in foreign.import.scm
(define ##sys#chicken.condition-macro-environment '()) ; used later in chicken.condition.import.scm
+(define ##sys#chicken.type-macro-environment '()) ; used later in chicken.condition.import.scm
(define (##sys#ensure-transformer t #!optional loc)
(cond ((procedure? t) (##sys#slot (##sys#er-transformer t) 1)) ; DEPRECATED
diff --git a/modules.scm b/modules.scm
index 441e85ae..a923fe01 100644
--- a/modules.scm
+++ b/modules.scm
@@ -987,6 +987,9 @@
(##sys#register-core-module
'chicken.module #f '() ##sys#chicken.module-macro-environment)
+(##sys#register-core-module
+ 'chicken.type #f '() ##sys#chicken.type-macro-environment)
+
(##sys#register-primitive-module
'srfi-0 '() (se-subset '(cond-expand) ##sys#default-macro-environment))
Trap