;; 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-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-ci=? string-ci? string-ci>=? string-locale-ci=? string-locale? 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)) )