>From e95e14a09488bc01d64720fa103525a90931e1bf Mon Sep 17 00:00:00 2001 From: Evan Hanson Date: Mon, 11 Sep 2017 08:41:41 +1200 Subject: [PATCH] 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. --- README | 1 + chicken-syntax.scm | 314 +++++++++++++++++++++++++------------------------- distribution/manifest | 2 + expand.scm | 1 + modules.scm | 3 + 5 files changed, 167 insertions(+), 154 deletions(-) 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)) -- 2.11.0