source: project/release/4/dsssl-utils/trunk/typed-define.scm @ 34913

Last change on this file since 34913 was 34913, checked in by Kon Lovett, 3 years ago

no params are funcs too

File size: 2.8 KB
Line 
1;;;; typed-define.scm -*- Hen -*-
2;;;; Kon Lovett, Oct '17
3
4(module typed-define
5
6(;export
7  define:-record-type
8  define:
9)
10
11(import scheme)
12
13;; typed scheme
14
15(define-syntax define:-record-type
16  (syntax-rules ()
17    ((_ ?tag (?ctor-id ?ctor-args ...) ?pred-id ?feld-specs ...)
18      (begin
19        (: ?ctor-id (#!rest --> (struct ?tag)))
20        (: ?pred-id (* --> boolean))
21        ;build type-dict from ?ctor-args ...
22        (define-record-type ?tag
23          (?ctor-id ?ctor-args ...)
24          ?pred-id
25          ?feld-specs ...) ) ) ) )
26
27(define-syntax define:
28  (syntax-rules (-> --> #!optional #!rest #!key)
29    ;
30    ;Pure
31    ;
32    ((_ (?name) --> ?rt ?body ...)
33      (define:-procedure (?name) --> ?rt ?body ...) )
34    ;
35    ((_ (?name (?v ?t) ...) --> ?rt ?body ...)
36      (define:-procedure (?name (?v ?t) ...) --> ?rt ?body ...) )
37    ;
38    ((_ (?name . (?rest ?at)) --> ?rt ?body ...)
39      (define:-procedure (?name . (?rest ?at)) --> ?rt ?body ...) )
40    ;
41    ((_ (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) --> ?rt ?body ...)
42      (define:-procedure (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) --> ?rt ?body ...) )
43    ;
44    ;Impure
45    ;
46    ((_ (?name) -> ?rt ?body ...)
47      (define:-procedure (?name) -> ?rt ?body ...) )
48    ;
49    ((_ (?name (?v ?t) ...) -> ?rt ?body ...)
50      (define:-procedure (?name (?v ?t) ...) -> ?rt ?body ...) )
51    ;
52    ((_ (?name . (?rest ?at)) -> ?rt ?body ...)
53      (define:-procedure (?name . (?rest ?at)) -> ?rt ?body ...) )
54    ;
55    ((_ (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) -> ?rt ?body ...)
56      (define:-procedure (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) -> ?rt ?body ...) )
57    ;
58    ;Impure Convenience
59    ;
60    ((_ (?name) ?body ...)
61      (define: (?name) -> void
62        ?body ...) )
63    ;
64    ((_ (?name (?v ?t) ...) ?body ...)
65      (define: (?name (?v ?t) ...) -> void
66        ?body ...) )
67    ;
68    ((_ (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) ?body ...)
69      (define: (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) -> void
70        ?body ...) ) ) )
71
72;typed scheme support
73(define-syntax define:-procedure
74  (syntax-rules ()
75    ;
76    ;XXX
77    ;
78    ((_ (?name) ?arrow ?rt ?body ...)
79      (begin
80        (: ?name (?arrow ?rt))
81        (define (?name)
82          ?body ... ) ) )
83    ;
84    ((_ (?name (?v ?t) ...) ?arrow ?rt ?body ...)
85      (begin
86        (: ?name (?t ... ?arrow ?rt))
87        (define (?name ?v ...)
88          ?body ... ) ) )
89    ;
90    ((_ (?name . (?rest ?at)) ?arrow ?rt ?body ...)
91      (begin
92        (: ?name (#!rest ?arrow ?rt))
93        (define (?name . ?rest)
94          ?body ... ) ) )
95    ;
96    ((_ (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) ?arrow ?rt ?body ...)
97      (begin
98        (: ?name (?t ... ?tn #!rest ?arrow ?rt))
99        (define (?name ?v ... ?vn . ?rest)
100          ?body ... ) ) ) ) )
101
102) ;module typed-define
Note: See TracBrowser for help on using the repository browser.