Welcome to the CHICKEN Scheme pasting service
no title pasted by alice on Mon Jul 29 07:23:35 2019
; types.scm (module types * (import scheme) (import chicken.base) (import chicken.type) (import typed-records) (define-record r (id : fixnum) (name : string)) (define r-def? r?) ;(: r-def-lam? ((struct r) --> boolean)) (define r-def-lam? (lambda (a) (r? a))) ) ; record-test.scm (module record-test () (import scheme) (import chicken.base) (import chicken.type) (import chicken.process-context) (import chicken.format) (import chicken.memory.representation) (import types) (define x (make-r 1 "alice")) (printf "-x-\nr?: ~A\nr-def?: ~A\nr-def-lam?: ~A\ntag: ~A\n---\n\n" (r? x) (r-def? x) (r-def-lam? x) (block-ref x 0)) (define y ((if (> (length (command-line-arguments)) 10000) cons make-r) 2 "bob")) (printf "-y-\nr?: ~A\nr-def?: ~A\nr-def-lam?: ~A\ntag: ~A\n---\n\n" (r? y) (r-def? y) (r-def-lam? y) (block-ref y 0)) ) ; output alice@venus:~/code/chicken/record-test % pontiff build --verbose && pontiff run constructing build order... building "record-test"... /usr/bin/env chicken ../src/types.scm -output-file __types.c -specialize -strict-types -local -lfa2 -inline -inline-global -optimize-leaf-routines -emit-import-library types -unit __types -emit-types-file __types.types /usr/bin/env clang __types.c -o __types.o -c -fno-strict-aliasing -fwrapv -DHAVE_CHICKEN_CONFIG_H -DC_ENABLE_PTABLES -O2 -fomit-frame-pointer -fPIC -DPIC -I/usr/include/chicken /usr/bin/env chicken ../src/record-test.scm -output-file __record-test.c -specialize -strict-types -local -lfa2 -inline -inline-global -optimize-leaf-routines -uses __types -consult-types-file __types.types /usr/bin/env clang __record-test.c -o __record-test.o -c -fno-strict-aliasing -fwrapv -DHAVE_CHICKEN_CONFIG_H -DC_ENABLE_PTABLES -O2 -fomit-frame-pointer -fPIC -DPIC -I/usr/include/chicken /usr/bin/env clang __types.o __record-test.o -o record-test -fuse-ld=lld -L/usr/lib -L/usr/local/lib -Wl,-R/usr/lib -Wl,-R/usr/local/lib -lchicken -lm -ldl built "record-test" running "record-test"... -x- r?: #t r-def?: #t r-def-lam?: #f tag: r --- -y- r?: #t r-def?: #t r-def-lam?: #t tag: types#r ---
typed-records patch added by megane on Mon Jul 29 14:55:47 2019
Index: typed-records.scm =================================================================== --- typed-records.scm (revision 37805) +++ typed-records.scm (working copy) @@ -15,7 +15,13 @@ (rename defstruct (defstruct defstruct1))) (import-for-syntax (srfi 1) (chicken base)) + (import (only chicken.syntax define-for-syntax)) + (define-for-syntax (get-tag plain-name) + (if (##sys#current-module) + (symbol-append + (##sys#module-name (##sys#current-module)) '|#| plain-name) + plain-name)) (define-syntax define-record (er-macro-transformer @@ -51,7 +57,7 @@ (,@(map cdr names/types) -> (struct ,name)) (,(map cdr names/types) (##sys#make-structure - ',name + ',(get-tag name) ,@(list-tabulate (length names/types) (lambda (i) `#(,(add1 i))))))) @@ -138,7 +144,7 @@ ctor)))) (cdr ctor)) (##sys#make-structure - ',name + ',(get-tag name) ,@(let lp [(names (map first accs/mods/types)) (l '())] (if (null? names)