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)

Your annotation:

Enter a new annotation:

Your nick:
The title of your paste:
Your paste (mandatory) :
Type in the text below:
            _         _       
  __ _  ___| |__   __| |_   __
 / _` |/ __| '_ \ / _` \ \ / /
| (_| | (__| | | | (_| |\ V / 
 \__,_|\___|_| |_|\__,_| \_/  
                              
Visually impaired? Let me spell it for you (wav file) download WAV