215 lines
8.4 KiB
Racket
215 lines
8.4 KiB
Racket
;; This module defines all the functions necessary to write FrTime programs,
|
|
;; as well as their lowered equivalents. It doesn't know how to perform
|
|
;; optimization, though -- that is left to the frtime-opt module.
|
|
(module frtime-opt-lang mzscheme
|
|
(require (prefix frtime: frtime/frtime))
|
|
(require-for-syntax frtime/opt/lowered-equivs)
|
|
|
|
;; Export a function that is just a lifted version of a standard
|
|
;; function (with the same name).
|
|
;; TBD: don't import from frtime at all -- just lift the original function
|
|
(define-syntax (provide/lifted stx)
|
|
(syntax-case stx ()
|
|
[(_ MOD FUNC)
|
|
(let ([lowered-equiv-id (make-lowered-equiv-id #'FUNC)])
|
|
#`(begin (require (rename frtime/frtime-big lifted-func FUNC))
|
|
(provide (rename lifted-func FUNC))
|
|
(require (rename MOD #,lowered-equiv-id FUNC))
|
|
(provide #,lowered-equiv-id)))]
|
|
[(_ MOD FUNC FUNCS ...)
|
|
#`(begin (provide/lifted MOD FUNC)
|
|
(provide/lifted MOD FUNCS ...))]))
|
|
|
|
(define-syntax (provide/already-lowered stx)
|
|
(syntax-case stx ()
|
|
[(_ FUNC)
|
|
(let ([lowered-equiv-id (make-lowered-equiv-id #'FUNC)])
|
|
#`(begin (require (only frtime/frtime-big FUNC))
|
|
;; note: the definition is necessary here because otherwise the lowered
|
|
;; equiv doesn't become part of the module's namespace, and there's
|
|
;; no way to find the list of identifiers exported by a module other
|
|
;; than by filtering its namespace (see all-provided-symbols in
|
|
;; lowered-equivs.ss)
|
|
(define #,lowered-equiv-id FUNC)
|
|
(provide FUNC)
|
|
(provide #,lowered-equiv-id)))]
|
|
[(_ FUNC FUNCS ...)
|
|
#`(begin (provide/already-lowered FUNC)
|
|
(provide/already-lowered FUNCS ...))]))
|
|
|
|
(define-syntax provide/no-equiv
|
|
(syntax-rules ()
|
|
[(_ FUNC)
|
|
(begin (require (rename frtime/frtime-big func FUNC))
|
|
(provide (rename func FUNC)))]
|
|
[(_ FUNC FUNCS ...)
|
|
(begin (provide/no-equiv FUNC)
|
|
(provide/no-equiv FUNCS ...))]))
|
|
|
|
(provide/lifted mzscheme
|
|
;; equality
|
|
eq? equal? eqv?
|
|
|
|
;; types
|
|
boolean? symbol? #;vector? number? string? char? pair? void? procedure? #;port? eof-object?
|
|
|
|
;; numbers and math
|
|
zero? even? odd? positive? negative? integer? real? rational? complex? exact? inexact?
|
|
+ - * / quotient remainder modulo
|
|
= < > <= >=
|
|
add1 sub1 min max
|
|
cos sin tan atan asin acos ;; trig
|
|
abs log sqrt integer-sqrt exp expt floor ceiling round truncate ;; reals
|
|
numerator denominator rationalize lcm gcd ;; fractions
|
|
imag-part real-part magnitude angle make-rectangular make-polar ;; complex numbers
|
|
bitwise-not bitwise-xor bitwise-and bitwise-ior arithmetic-shift ;; bits
|
|
|
|
|
|
;; booleans and conditionals
|
|
and or not when unless cond case
|
|
|
|
;; characters
|
|
char>? char<? char=? char-ci>=? char-ci<=? char>=? char<=?
|
|
char-upper-case? #;char-lower-case? char-alphabetic? char-numeric? char-whitespace?
|
|
char-upcase char-downcase
|
|
|
|
;; strings
|
|
string string-length string-append substring string-ref
|
|
string=? string<? string<=? string>? string>=?
|
|
string-ci=? string-ci<? string-ci<=? #;string-ci>? string-ci>=?
|
|
string-locale-ci=? string-locale<? string-locale-ci<? string-locale-ci>?
|
|
format
|
|
|
|
;; lists
|
|
null? list? car cdr caar cadr cddr caddr cdddr cadddr cddddr
|
|
length list-ref list-tail
|
|
assq assv #;assoc memq memv #;member
|
|
|
|
;; vectors
|
|
make-vector vector #;vector-length vector-ref
|
|
|
|
;; dates
|
|
make-date date? date-dst? seconds->date current-seconds current-milliseconds
|
|
date-year date-month date-day date-year-day date-week-day
|
|
date-hour date-minute date-second date-time-zone-offset
|
|
|
|
;; conversion
|
|
char->integer integer->char
|
|
symbol->string string->symbol
|
|
number->string string->number
|
|
list->string string->list
|
|
list->vector vector->list
|
|
inexact->exact exact->inexact
|
|
|
|
;; exceptions
|
|
exn-message exn-continuation-marks exn:fail? continuation-mark-set->list
|
|
with-handlers
|
|
|
|
;; syntax
|
|
expand #;expand-syntax syntax syntax-object->datum syntax-case syntax-rules
|
|
|
|
;; paths
|
|
path? path-string? string->path path->string
|
|
bytes->path path->bytes build-path absolute-path? relative-path?
|
|
complete-path? path->complete-path resolve-path path-replace-suffix
|
|
expand-path simplify-path normal-case-path split-path
|
|
|
|
;; I/O
|
|
printf fprintf file-exists? #;link-exists? #;make-file-or-directory-link
|
|
#;file-or-directory-modify-seconds #;file-or-directory-permissions
|
|
#;rename-file-or-directory #;file-size #;copy-file #;delete-file
|
|
|
|
;; context
|
|
current-error-port current-security-guard collection-path
|
|
#;current-namespace #;current-command-line-arguments #;current-custodian
|
|
current-directory #;current-eventspace
|
|
|
|
;; misc
|
|
eval procedure-arity regexp-match void system-type
|
|
)
|
|
|
|
(provide/lifted srfi/1
|
|
first second)
|
|
|
|
;; things that serve as their own lowered equivalent
|
|
(provide/already-lowered
|
|
event-receiver send-event
|
|
nothing null collect-garbage)
|
|
|
|
;; functions with no lowered equivalents
|
|
(provide/no-equiv
|
|
;; no equiv because these inherently work with signals
|
|
seconds milliseconds value-now value-now/sync value-now/no-copy inf-delay delay-by synchronize
|
|
for-each-e! map-e filter-e merge-e once-e accum-e accum-b collect-e collect-b when-e while-e -=> ==> =#>
|
|
changes hold switch snapshot snapshot/sync snapshot-e integral derivative
|
|
signal? undefined? undefined lift-strict =#=>
|
|
|
|
;; no equiv because we don't support lvalues
|
|
set! set-cell! new-cell
|
|
|
|
;; no equiv because we have special handling for these special forms
|
|
begin if let let* let-values letrec #;letrec-values
|
|
define-values values define-syntax define-syntaxes
|
|
|
|
;; no lowered equiv because it allocates memory
|
|
list list* cons reverse append
|
|
|
|
;; no equiv because it's a macro that expands into more primitive code
|
|
case-lambda let*-values mk-command-lambda
|
|
|
|
;; no equiv because these accept higher-order functions, which may not
|
|
;; have been lowered
|
|
for-each map andmap ormap apply ;build-string #;build-vector
|
|
|
|
;; no equiv because these have non-local control flow (can't get your
|
|
;; hands on the return value in order to lift it again).
|
|
raise raise-exceptions raise-type-error error exit let/ec
|
|
|
|
;; no equiv because I haven't completely thought through these
|
|
lambda quote unquote unquote-splicing make-parameter parameterize
|
|
procedure-arity-includes? dynamic-require)
|
|
|
|
(provide #%app #%top #%datum require require-for-syntax provide define)
|
|
(provide display) ;; for debugging
|
|
|
|
#;(require frtime/frlibs/list
|
|
frtime/frlibs/etc
|
|
frtime/frlibs/math
|
|
frtime/frlibs/date)
|
|
|
|
#;(provide (all-from frtime/frlibs/list)
|
|
(all-from frtime/frlibs/etc)
|
|
(all-from frtime/frlibs/math)
|
|
(all-from frtime/frlibs/date))
|
|
|
|
;; this define-struct macro defines a lowered equiv for all the
|
|
;; accessor functions
|
|
(define-syntax (my-define-struct stx)
|
|
(define (make-lowered-accessor struct-id field-id)
|
|
(let* ([upper-id (datum->syntax-object
|
|
field-id
|
|
(string->symbol
|
|
(format "~s-~s"
|
|
(syntax-e struct-id)
|
|
(syntax-e field-id))))]
|
|
[lower-id (make-lowered-equiv-id upper-id)])
|
|
;; TBD: can we be smarter? can we go straight for the field value and
|
|
;; bypass any signal-checking logic? *is* there any signal-checking logic?
|
|
#`(define #,lower-id #,upper-id)))
|
|
(define (lowered-equiv-defns struct-id field-ids)
|
|
(let ([lowered-accessors (map (lambda (field-id)
|
|
(make-lowered-accessor struct-id field-id))
|
|
field-ids)])
|
|
#`(begin . #,lowered-accessors)))
|
|
(syntax-case stx ()
|
|
[(_ (STRUCT BASE) (FIELD ...) . REST)
|
|
#`(begin
|
|
(frtime:define-struct (STRUCT BASE) (FIELD ...) . REST)
|
|
#,(lowered-equiv-defns #'STRUCT (syntax->list #'(FIELD ...))))]
|
|
[(_ STRUCT (FIELD ...) . REST)
|
|
#`(begin
|
|
(frtime:define-struct STRUCT (FIELD ...) . REST)
|
|
#,(lowered-equiv-defns #'STRUCT (syntax->list #'(FIELD ...))))]))
|
|
(provide (rename my-define-struct define-struct))
|
|
)
|