1#lang racket
2
3;; This module defines all the functions necessary to write FrTime programs,
4;; as well as their lowered equivalents.  It doesn't know how to perform
5;; optimization, though -- that is left to the frtime-opt module.
6
7;; TODO(ghcooper/paddymahoney): Fix the duplicate requires and uncomment the
8;; body of this module.
9#|
10(require (prefix-in frtime: frtime/frtime))
11(require (for-syntax racket/base frtime/opt/lowered-equivs))
12(require (only-in frtime/frtime-big event-receiver send-event
13                  nothing null collect-garbage))
14
15;; Export a function that is just a lifted version of a standard
16;; function (with the same name).
17;; TBD: don't import from frtime at all -- just lift the original function
18(define-syntax (provide/lifted stx)
19  (syntax-case stx ()
20    [(_ MOD FUNC)
21     (let ([lowered-equiv-id (make-lowered-equiv-id #'FUNC)])
22       #`(begin (require (rename-in frtime/frtime-big [FUNC lifted-func]))
23                (provide (rename-out [lifted-func FUNC]))
24                (require (rename-in MOD [FUNC #,lowered-equiv-id]))
25                (provide #,lowered-equiv-id)))]
26    [(_ MOD FUNC FUNCS ...)
27     #`(begin (provide/lifted MOD FUNC)
28              (provide/lifted MOD FUNCS ...))]))
29
30(define-syntax (provide/already-lowered stx)
31  (syntax-case stx ()
32    [(_ FUNC)
33     (let ([lowered-equiv-id (make-lowered-equiv-id #'FUNC)])
34       #`(begin (require (only-in frtime/frtime-big FUNC))
35                ;; note: the definition is necessary here because otherwise the lowered
36                ;; equiv doesn't become part of the module's namespace, and there's
37                ;; no way to find the list of identifiers exported by a module other
38                ;; than by filtering its namespace (see all-provided-symbols in
39                ;; lowered-equivs.rkt)
40                (define #,lowered-equiv-id FUNC)
41                (provide FUNC)
42                (provide #,lowered-equiv-id)))]
43    [(_ FUNC FUNCS ...)
44     #`(begin (provide/already-lowered FUNC)
45              (provide/already-lowered FUNCS ...))]))
46
47(define-syntax provide/no-equiv
48  (syntax-rules ()
49    [(_ FUNC)
50     (begin (require (rename-in frtime/frtime-big [FUNC func]))
51            (provide (rename-out [func FUNC])))]
52    [(_ FUNC FUNCS ...)
53     (begin (provide/no-equiv FUNC)
54            (provide/no-equiv FUNCS ...))]))
55
56(provide/lifted racket
57                ;; equality
58                eq? equal? eqv?
59
60                ;; types
61                boolean? symbol? #;vector? number? string? char? pair? void? procedure? #;port? eof-object?
62
63                ;; numbers and math
64                zero? even? odd? positive? negative? integer? real? rational? complex? exact? inexact?
65                + - * / quotient remainder modulo
66                = < > <= >=
67                add1 sub1 min max
68                cos sin tan atan asin acos                                        ;; trig
69                abs log sqrt integer-sqrt exp expt floor ceiling round truncate   ;; reals
70                numerator denominator rationalize lcm gcd                         ;; fractions
71                imag-part real-part magnitude angle make-rectangular make-polar   ;; complex numbers
72                bitwise-not bitwise-xor bitwise-and bitwise-ior arithmetic-shift  ;; bits
73
74
75                ;; booleans and conditionals
76                and or not when unless cond case
77
78                ;; characters
79                char>? char<? char=? char-ci>=? char-ci<=? char>=? char<=?
80                char-upper-case? #;char-lower-case? char-alphabetic? char-numeric? char-whitespace?
81                char-upcase char-downcase
82
83                ;; strings
84                string string-length string-append substring string-ref
85                string=? string<? string<=? string>? string>=?
86                string-ci=? string-ci<? string-ci<=? #;string-ci>? string-ci>=?
87                string-locale-ci=? string-locale<? string-locale-ci<? string-locale-ci>?
88                format
89
90                ;; lists
91                null? list? car cdr caar cadr cddr caddr cdddr cadddr cddddr
92                length list-ref list-tail
93                assq assv #;assoc memq memv #;member
94
95                ;; vectors
96                make-vector vector #;vector-length vector-ref
97
98                ;; dates
99                make-date date? date-dst? seconds->date current-seconds current-milliseconds
100                date-year date-month date-day date-year-day date-week-day
101                date-hour date-minute date-second date-time-zone-offset
102
103                ;; conversion
104                char->integer integer->char
105                symbol->string string->symbol
106                number->string string->number
107                list->string string->list
108                list->vector vector->list
109                inexact->exact exact->inexact
110
111                ;; exceptions
112                exn-message exn-continuation-marks exn:fail? continuation-mark-set->list
113                with-handlers
114
115                ;; syntax
116                expand #;expand-syntax syntax syntax->datum syntax-case syntax-rules
117
118                ;; paths
119                path? path-string? string->path path->string
120                bytes->path path->bytes build-path absolute-path? relative-path?
121                complete-path? path->complete-path resolve-path path-replace-suffix
122                cleanse-path simplify-path normal-case-path split-path
123
124                ;; I/O
125                printf fprintf file-exists? #;link-exists? #;make-file-or-directory-link
126                #;file-or-directory-modify-seconds #;file-or-directory-permissions
127                #;rename-file-or-directory #;file-size #;copy-file #;delete-file
128
129                ;; context
130                current-error-port current-security-guard collection-path
131                #;current-namespace #;current-command-line-arguments #;current-custodian
132                current-directory #;current-eventspace
133
134                ;; misc
135                eval procedure-arity regexp-match void system-type
136                )
137
138(provide/lifted srfi/1
139                first second)
140
141;; things that serve as their own lowered equivalent
142(provide/already-lowered
143 event-receiver send-event
144 nothing null collect-garbage)
145
146;; functions with no lowered equivalents
147(provide/no-equiv
148 ;; no equiv because these inherently work with signals
149 seconds milliseconds value-now value-now/sync value-now/no-copy inf-delay delay-by synchronize
150 for-each-e! map-e filter-e merge-e once-e accum-e accum-b collect-e collect-b when-e while-e -=> ==> =#>
151 changes hold switch snapshot snapshot/sync snapshot-e integral derivative
152 signal? undefined? undefined lift-strict =#=>
153
154 ;; no equiv because we don't support lvalues
155 set! set-cell! new-cell
156
157 ;; no equiv because we have special handling for these special forms
158 begin if let let* let-values letrec #;letrec-values
159 define-values values define-syntax define-syntaxes
160
161 ;; no lowered equiv because it allocates memory
162 list list* cons reverse append
163
164 ;; no equiv because it's a macro that expands into more primitive code
165 case-lambda let*-values mk-command-lambda
166
167 ;; no equiv because these accept higher-order functions, which may not
168 ;; have been lowered
169 for-each map andmap ormap apply ;build-string #;build-vector
170
171 ;; no equiv because these have non-local control flow (can't get your
172 ;; hands on the return value in order to lift it again).
173 raise raise-exceptions raise-type-error error exit let/ec
174
175 ;; no equiv because I haven't completely thought through these
176 lambda quote unquote unquote-splicing make-parameter parameterize
177 procedure-arity-includes? dynamic-require)
178
179(provide #%app #%top #%datum require for-syntax provide define)
180(provide display) ;; for debugging
181
182#;(require frtime/frlibs/list
183           frtime/frlibs/etc
184           frtime/frlibs/math
185           frtime/frlibs/date)
186
187#;(provide (all-from frtime/frlibs/list)
188           (all-from frtime/frlibs/etc)
189           (all-from frtime/frlibs/math)
190           (all-from frtime/frlibs/date))
191
192;; this define-struct macro defines a lowered equiv for all the
193;; accessor functions
194(define-syntax (my-define-struct stx)
195  (define (make-lowered-accessor struct-id field-id)
196    (let* ([upper-id (datum->syntax
197                      field-id
198                      (string->symbol
199                       (format "~s-~s"
200                               (syntax-e struct-id)
201                               (syntax-e field-id))))]
202           [lower-id (make-lowered-equiv-id upper-id)])
203      ;; TBD: can we be smarter?  can we go straight for the field value and
204      ;; bypass any signal-checking logic?  *is* there any signal-checking logic?
205      #`(define #,lower-id #,upper-id)))
206  (define (lowered-equiv-defns struct-id field-ids)
207    (let ([lowered-accessors (map (lambda (field-id)
208                                    (make-lowered-accessor struct-id field-id))
209                                  field-ids)])
210      #`(begin . #,lowered-accessors)))
211  (syntax-case stx ()
212    [(_ (STRUCT BASE) (FIELD ...) . REST)
213     #`(begin
214         (frtime:define-struct (STRUCT BASE) (FIELD ...) . REST)
215         #,(lowered-equiv-defns #'STRUCT (syntax->list #'(FIELD ...))))]
216    [(_ STRUCT (FIELD ...) . REST)
217     #`(begin
218         (frtime:define-struct STRUCT (FIELD ...) . REST)
219         #,(lowered-equiv-defns #'STRUCT (syntax->list #'(FIELD ...))))]))
220(provide (rename-out [my-define-struct define-struct]))
221|#
222