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

Last change on this file since 34866 was 34866, checked in by Kon Lovett, 4 years ago

define:-record-type st

File size: 2.4 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 (?v ?t) ...) --> ?rt ?body ...)
33      (define:-procedure (?name (?v ?t) ...) --> ?rt ?body ...) )
34    ;
35    ((_ (?name . (?rest ?at)) --> ?rt ?body ...)
36      (define:-procedure (?name . (?rest ?at)) --> ?rt ?body ...) )
37    ;
38    ((_ (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) --> ?rt ?body ...)
39      (define:-procedure (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) --> ?rt ?body ...) )
40    ;
41    ;Impure
42    ;
43    ((_ (?name (?v ?t) ...) -> ?rt ?body ...)
44      (define:-procedure (?name (?v ?t) ...) -> ?rt ?body ...) )
45    ;
46    ((_ (?name . (?rest ?at)) -> ?rt ?body ...)
47      (define:-procedure (?name . (?rest ?at)) -> ?rt ?body ...) )
48    ;
49    ((_ (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) -> ?rt ?body ...)
50      (define:-procedure (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) -> ?rt ?body ...) )
51    ;
52    ;Impure Convenience
53    ;
54    ((_ (?name (?v ?t) ...) ?body ...)
55      (define: (?name (?v ?t) ...) -> void
56        ?body ...) )
57    ;
58    ((_ (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) ?body ...)
59      (define: (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) -> void
60        ?body ...) ) ) )
61
62;typed scheme support
63(define-syntax define:-procedure
64  (syntax-rules ()
65    ;
66    ;XXX
67    ;
68    ((_ (?name (?v ?t) ...) ?arrow ?rt ?body ...)
69      (begin
70        (: ?name (?t ... ?arrow ?rt))
71        (define (?name ?v ...)
72          ?body ... ) ) )
73    ;
74    ((_ (?name . (?rest ?at)) ?arrow ?rt ?body ...)
75      (begin
76        (: ?name (#!rest ?arrow ?rt))
77        (define (?name . ?rest)
78          ?body ... ) ) )
79    ;
80    ((_ (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) ?arrow ?rt ?body ...)
81      (begin
82        (: ?name (?t ... ?tn #!rest ?arrow ?rt))
83        (define (?name ?v ... ?vn . ?rest)
84          ?body ... ) ) ) ) )
85
86) ;module typed-define
Note: See TracBrowser for help on using the repository browser.