From a7256c91bfe12c888d625945b948d42d3cebdefe Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 25 Jun 2009 22:09:54 +0000 Subject: [PATCH] Converting to scheme from mzscheme svn: r15281 --- collects/frtime/date.ss | 709 ++++++++++++++---------------- collects/frtime/frp-snip.ss | 323 +++++++------- collects/frtime/frtime-tool.ss | 184 ++++---- collects/frtime/graphics-sig.ss | 132 +++--- collects/frtime/graphics-unit.ss | 25 +- collects/frtime/graphics.ss | 16 +- collects/frtime/lowered-equivs.ss | 206 ++++----- 7 files changed, 779 insertions(+), 816 deletions(-) diff --git a/collects/frtime/date.ss b/collects/frtime/date.ss index f22503b510..34853102ed 100644 --- a/collects/frtime/date.ss +++ b/collects/frtime/date.ss @@ -1,392 +1,359 @@ +#lang scheme +(require "list.ss") +(require (rename-in (only-in "frtime.ss" provide) + [provide frtime:provide])) -(module date mzscheme - - (require "list.ss") - (require (rename "frtime.ss" frtime:provide provide)) - - (frtime:provide +(frtime:provide (lifted date->string - date-display-format - find-seconds - - date->julian/scalinger - julian/scalinger->string)) + date-display-format + find-seconds + + date->julian/scalinger + julian/scalinger->string)) - ;; Support for Julian calendar added by Shriram; - ;; current version only works until 2099 CE Gregorian +;; Support for Julian calendar added by Shriram; +;; current version only works until 2099 CE Gregorian - #| +(define legal-formats + (list 'american 'chinese 'german 'indian 'irish 'julian 'iso-8601 'rfc2822)) - (define-primitive seconds->date (num -> structure:date)) - (define-primitive current-seconds (-> num)) - (define-primitive date-second (structure:date -> num)) - (define-primitive date-minute (structure:date -> num)) - (define-primitive date-hour (structure:date -> num)) - (define-primitive date-day (structure:date -> num)) - (define-primitive date-month (structure:date -> num)) - (define-primitive date-year (structure:date -> num)) - (define-primitive date-week-day (structure:date -> num)) - (define-primitive date-year-day (structure:date -> num)) - (define-primitive date-dst? (structure:date -> bool)) - (define-primitive make-date (num num num num num num num num bool -> - structure:date)) - (define-primitive expr->string (a -> string)) - (define-primitive foldl (case-> - ((a z -> z) z (listof a) -> z) - ((a b z -> z) z (listof a) (listof b) -> z) - ((a b c z -> z) z (listof a) (listof b) (listof c) -> z) - (((arglistof x) ->* z) z (listof (arglistof x)) ->* z))) - (define-primitive foldr (case-> - ((a z -> z) z (listof a) -> z) - ((a b z -> z) z (listof a) (listof b) -> z) - ((a b c z -> z) z (listof a) (listof b) (listof c) -> z) - (((arglistof x) ->* z) z (listof (arglistof x)) ->* z))) +(define date-display-format + (make-parameter 'american + (lambda (s) + (unless (memq s legal-formats) + (raise-type-error 'date-display-format + (format "symbol in ~a" legal-formats) + s)) + s))) - |# +(define month/number->string + (lambda (x) + (case x + [(12) "December"] [(1) "January"] [(2) "February"] + [(3) "March"] [(4) "April"] [(5) "May"] + [(6) "June"] [(7) "July"] [(8) "August"] + [(9) "September"] [(10) "October"] [(11) "November"] + [else ""]))) - (define legal-formats - (list 'american 'chinese 'german 'indian 'irish 'julian 'iso-8601 'rfc2822)) +(define day/number->string + (lambda (x) + (case x + [(0) "Sunday"] + [(1) "Monday"] + [(2) "Tuesday"] + [(3) "Wednesday"] + [(4) "Thursday"] + [(5) "Friday"] + [(6) "Saturday"] + [else ""]))) - (define date-display-format - (make-parameter 'american - (lambda (s) - (unless (memq s legal-formats) - (raise-type-error 'date-display-format - (format "symbol in ~a" legal-formats) - s)) - s))) +(define date->string + (case-lambda + [(date) (date->string date #f)] + [(date time?) + (let* ((add-zero (lambda (n) (if (< n 10) + (string-append "0" (number->string n)) + (number->string n)))) + (year (number->string (date-year date))) + (num-month (number->string (date-month date))) + (week-day (day/number->string (date-week-day date))) + (week-day-num (date-week-day date)) + (month (month/number->string (date-month date))) + (day (number->string (date-day date))) + (day-th (if (<= 11 (date-day date) 13) + "th" + (case (modulo (date-day date) 10) + [(1) "st"] + [(2) "nd"] + [(3) "rd"] + [(0 4 5 6 7 8 9) "th"]))) + (hour (date-hour date)) + (am-pm (if (>= hour 12) "pm" "am")) + (hour24 (add-zero hour)) + (hour12 (number->string + (cond + [(zero? hour) 12] + [(> hour 12) (- hour 12)] + [else hour]))) + (minute (add-zero (date-minute date))) + (second (add-zero (date-second date)))) + (let-values + ([(day time) + (case (date-display-format) + [(american) + (values (list week-day ", " month " " day day-th ", " year) + (list " " hour12 ":" minute ":" second am-pm))] + [(chinese) + (values + (list year "/" num-month "/" day + " \u661F\u671F" (case (date-week-day date) + [(0) "\u5929"] + [(1) "\u4E00"] + [(2) "\u4E8C"] + [(3) "\u4e09"] + [(4) "\u56DB"] + [(5) "\u4E94"] + [(6) "\u516D"] + [else ""])) + (list " " hour24 ":" minute ":" second))] + [(indian) + (values (list day "-" num-month "-" year) + (list " " hour12 ":" minute ":" second am-pm))] + [(german) + (values (list day ". " + (case (date-month date) + [(1) "Januar"] + [(2) "Februar"] + [(3) "M\344rz"] + [(4) "April"] + [(5) "Mai"] + [(6) "Juni"] + [(7) "Juli"] + [(8) "August"] + [(9) "September"] + [(10) "Oktober"] + [(11) "November"] + [(12) "Dezember"] + [else ""]) + " " year) + (list ", " hour24 "." minute))] + [(irish) + (values (list week-day ", " day day-th " " month " " year) + (list ", " hour12 ":" minute am-pm))] + [(julian) + (values (list (julian/scalinger->string + (date->julian/scalinger date))) + (list ", " hour24 ":" minute ":" second))] + [(iso-8601) + (values + (list year "-" (add-zero (date-month date)) "-" (add-zero (date-day date))) + (list " " hour24 ":" minute ":" second))] + [(rfc2822) + (values + (list (substring week-day 0 3) ", " day " " (substring month 0 3) " " year) + (list* " " hour24 ":" minute ":" second " " + (let* ([delta (date-time-zone-offset date)] + [hours (quotient delta 3600)] + [minutes (modulo (quotient delta 60) 60)]) + (list + (if (negative? delta) "-" "") + (add-zero (abs hours)) + (add-zero minutes)))))] + [else (error 'date->string "unknown date-display-format: ~s" + (date-display-format))])]) + (apply string-append (if time? + (append day time) + day))))])) - (define month/number->string - (lambda (x) - (case x - [(12) "December"] [(1) "January"] [(2) "February"] - [(3) "March"] [(4) "April"] [(5) "May"] - [(6) "June"] [(7) "July"] [(8) "August"] - [(9) "September"] [(10) "October"] [(11) "November"] - [else ""]))) - - (define day/number->string - (lambda (x) - (case x - [(0) "Sunday"] - [(1) "Monday"] - [(2) "Tuesday"] - [(3) "Wednesday"] - [(4) "Thursday"] - [(5) "Friday"] - [(6) "Saturday"] - [else ""]))) +(define leap-year? + (lambda (year) + (or (= 0 (modulo year 400)) + (and (= 0 (modulo year 4)) + (not (= 0 (modulo year 100))))))) - (define date->string +;; it's not clear what months mean in this context -- use days +(define-struct date-offset (second minute hour day year)) + +(define date- + (lambda (date1 date2) + (let* ((second (- (date-second date1) (date-second date2))) + (minute (+ (- (date-minute date1) (date-minute date2)) + (if (< second 0) -1 0))) + (hour (+ (- (date-hour date1) (date-hour date2)) + (if (< minute 0) -1 0) + (cond [(equal? (date-dst? date1) (date-dst? date2)) 0] + [(date-dst? date1) -1] + [(date-dst? date2) 1]))) + (day (+ (- (date-year-day date1) (date-year-day date2)) + (if (< hour 0) -1 0))) + (year (+ (- (date-year date1) (date-year date2)) + (if (< day 0) -1 0))) + (fixup (lambda (s x) (if (< s 0) (+ s x) s)))) + (make-date-offset (fixup second 60) + (fixup minute 60) + (fixup hour 24) + (fixup day (if (leap-year? (date-year date1)) 366 365)) + year)))) + + +(define date-offset->string + (let ((first car) + (second cadr)) (case-lambda - [(date) (date->string date #f)] - [(date time?) - (let* ((add-zero (lambda (n) (if (< n 10) - (string-append "0" (number->string n)) - (number->string n)))) - (year (number->string (date-year date))) - (num-month (number->string (date-month date))) - (week-day (day/number->string (date-week-day date))) - (week-day-num (date-week-day date)) - (month (month/number->string (date-month date))) - (day (number->string (date-day date))) - (day-th (if (<= 11 (date-day date) 13) - "th" - (case (modulo (date-day date) 10) - [(1) "st"] - [(2) "nd"] - [(3) "rd"] - [(0 4 5 6 7 8 9) "th"]))) - (hour (date-hour date)) - (am-pm (if (>= hour 12) "pm" "am")) - (hour24 (add-zero hour)) - (hour12 (number->string - (cond - [(zero? hour) 12] - [(> hour 12) (- hour 12)] - [else hour]))) - (minute (add-zero (date-minute date))) - (second (add-zero (date-second date)))) - (let-values - ([(day time) - (case (date-display-format) - [(american) - (values (list week-day ", " month " " day day-th ", " year) - (list " " hour12 ":" minute ":" second am-pm))] - [(chinese) - (values - (list year "/" num-month "/" day - " \u661F\u671F" (case (date-week-day date) - [(0) "\u5929"] - [(1) "\u4E00"] - [(2) "\u4E8C"] - [(3) "\u4e09"] - [(4) "\u56DB"] - [(5) "\u4E94"] - [(6) "\u516D"] - [else ""])) - (list " " hour24 ":" minute ":" second))] - [(indian) - (values (list day "-" num-month "-" year) - (list " " hour12 ":" minute ":" second am-pm))] - [(german) - (values (list day ". " - (case (date-month date) - [(1) "Januar"] - [(2) "Februar"] - [(3) "M\344rz"] - [(4) "April"] - [(5) "Mai"] - [(6) "Juni"] - [(7) "Juli"] - [(8) "August"] - [(9) "September"] - [(10) "Oktober"] - [(11) "November"] - [(12) "Dezember"] - [else ""]) - " " year) - (list ", " hour24 "." minute))] - [(irish) - (values (list week-day ", " day day-th " " month " " year) - (list ", " hour12 ":" minute am-pm))] - [(julian) - (values (list (julian/scalinger->string - (date->julian/scalinger date))) - (list ", " hour24 ":" minute ":" second))] - [(iso-8601) - (values - (list year "-" (add-zero (date-month date)) "-" (add-zero (date-day date))) - (list " " hour24 ":" minute ":" second))] - [(rfc2822) - (values - (list (substring week-day 0 3) ", " day " " (substring month 0 3) " " year) - (list* " " hour24 ":" minute ":" second " " - (let* ([delta (date-time-zone-offset date)] - [hours (quotient delta 3600)] - [minutes (modulo (quotient delta 60) 60)]) - (list - (if (negative? delta) "-" "") - (add-zero (abs hours)) - (add-zero minutes)))))] - [else (error 'date->string "unknown date-display-format: ~s" - (date-display-format))])]) - (apply string-append (if time? - (append day time) - day))))])) - - (define leap-year? - (lambda (year) - (or (= 0 (modulo year 400)) - (and (= 0 (modulo year 4)) - (not (= 0 (modulo year 100))))))) + [(date) (date-offset->string date #f)] + [(date seconds?) + (let* ((fields (list (list (date-offset-year date) "year") + (list (date-offset-day date) "day") + (list (date-offset-hour date) "hour") + (list (date-offset-minute date) "minute") + (list (if seconds? (date-offset-second date) 0) "second"))) + (non-zero-fields (foldl (lambda (x l) + (if (= 0 (first x)) + l + (cons x l))) + null + fields)) + (one-entry (lambda (b) + (string-append + (number->string (first b)) + " " + (second b) + (if (= 1 (first b)) "" "s"))))) + (cond + [(null? non-zero-fields) ""] + [(null? (cdr non-zero-fields)) (one-entry (car non-zero-fields))] + [else (foldl (lambda (b string) + (cond + [(= 0 (first b)) string] + [(string=? string "") + (string-append "and " + (one-entry b) + string)] + [else (string-append (one-entry b) ", " string)])) + "" + non-zero-fields)]))]))) - ;; it's not clear what months mean in this context -- use days - (define-struct date-offset (second minute hour day year)) +(define days-per-month + (lambda (year month) + (cond + [(and (= month 2) (leap-year? year)) 29] + [(= month 2) 28] + [(<= month 7) (+ 30 (modulo month 2))] + [else (+ 30 (- 1 (modulo month 2)))]))) - (define date- - (lambda (date1 date2) - (let* ((second (- (date-second date1) (date-second date2))) - (minute (+ (- (date-minute date1) (date-minute date2)) - (if (< second 0) -1 0))) - (hour (+ (- (date-hour date1) (date-hour date2)) - (if (< minute 0) -1 0) - (cond [(equal? (date-dst? date1) (date-dst? date2)) 0] - [(date-dst? date1) -1] - [(date-dst? date2) 1]))) - (day (+ (- (date-year-day date1) (date-year-day date2)) - (if (< hour 0) -1 0))) - (year (+ (- (date-year date1) (date-year date2)) - (if (< day 0) -1 0))) - (fixup (lambda (s x) (if (< s 0) (+ s x) s)))) - (make-date-offset (fixup second 60) - (fixup minute 60) - (fixup hour 24) - (fixup day (if (leap-year? (date-year date1)) 366 365)) - year)))) +(define find-extreme-date-seconds + (lambda (start offset) + (let/ec found + (letrec ([find-between + (lambda (lo hi) + (let ([mid (floor (/ (+ lo hi) 2))]) + (if (or (and (positive? offset) (= lo mid)) + (and (negative? offset) (= hi mid))) + (found lo) + (let ([mid-ok? + (with-handlers ([exn:fail? (lambda (exn) #f)]) + (seconds->date mid) + #t)]) + (if mid-ok? + (find-between mid hi) + (find-between lo mid))))))]) + (let loop ([lo start][offset offset]) + (let ([hi (+ lo offset)]) + (with-handlers ([exn:fail? + (lambda (exn) + ; failed - must be between lo & hi + (find-between lo hi))]) + (seconds->date hi)) + ; succeeded; double offset again + (loop hi (* 2 offset)))))))) +(define get-min-seconds + (let ([d (delay (find-extreme-date-seconds (current-seconds) -1))]) + (lambda () + (force d)))) +(define get-max-seconds + (let ([d (delay (find-extreme-date-seconds (current-seconds) 1))]) + (lambda () + (force d)))) - (define date-offset->string - (let ((first car) - (second cadr)) - (case-lambda - [(date) (date-offset->string date #f)] - [(date seconds?) - (let* ((fields (list (list (date-offset-year date) "year") - (list (date-offset-day date) "day") - (list (date-offset-hour date) "hour") - (list (date-offset-minute date) "minute") - (list (if seconds? (date-offset-second date) 0) "second"))) - (non-zero-fields (foldl (lambda (x l) - (if (= 0 (first x)) - l - (cons x l))) - null - fields)) - (one-entry (lambda (b) - (string-append - (number->string (first b)) - " " - (second b) - (if (= 1 (first b)) "" "s"))))) - (cond - [(null? non-zero-fields) ""] - [(null? (cdr non-zero-fields)) (one-entry (car non-zero-fields))] - [else (foldl (lambda (b string) - (cond - [(= 0 (first b)) string] - [(string=? string "") - (string-append "and " - (one-entry b) - string)] - [else (string-append (one-entry b) ", " string)])) - "" - non-zero-fields)]))]))) +(define find-seconds + (lambda (sec min hour day month year) + (let ([signal-error + (lambda (msg) + (error 'find-secs (string-append + msg + " (inputs: ~a ~a ~a ~a ~a ~a)") + sec min hour day month year))]) + (let loop ([below-secs (get-min-seconds)] + [secs (floor (/ (+ (get-min-seconds) (get-max-seconds)) 2))] + [above-secs (get-max-seconds)]) + (let* ([date (seconds->date secs)] + [compare + (let loop ([inputs (list year month day + hour min sec)] + [tests (list (date-year date) + (date-month date) + (date-day date) + (date-hour date) + (date-minute date) + (date-second date))]) + (cond + [(null? inputs) 'equal] + [else (let ([input (car inputs)] + [test (car tests)]) + (if (= input test) + (loop (cdr inputs) (cdr tests)) + (if (<= input test) + 'input-smaller + 'test-smaller)))]))]) + ; (printf "~a ~a ~a~n" compare secs (date->string date)) + (cond + [(eq? compare 'equal) secs] + [(or (= secs below-secs) (= secs above-secs)) + (signal-error "non-existent date")] + [(eq? compare 'input-smaller) + (loop below-secs (floor (/ (+ secs below-secs) 2)) secs)] + [(eq? compare 'test-smaller) + (loop secs (floor (/ (+ above-secs secs) 2)) above-secs)])))))) - (define days-per-month - (lambda (year month) - (cond - [(and (= month 2) (leap-year? year)) 29] - [(= month 2) 28] - [(<= month 7) (+ 30 (modulo month 2))] - [else (+ 30 (- 1 (modulo month 2)))]))) +;; date->julian/scalinger : +;; date -> number [julian-day] - (define find-extreme-date-seconds - (lambda (start offset) - (let/ec found - (letrec ([find-between - (lambda (lo hi) - (let ([mid (floor (/ (+ lo hi) 2))]) - (if (or (and (positive? offset) (= lo mid)) - (and (negative? offset) (= hi mid))) - (found lo) - (let ([mid-ok? - (with-handlers ([exn:fail? (lambda (exn) #f)]) - (seconds->date mid) - #t)]) - (if mid-ok? - (find-between mid hi) - (find-between lo mid))))))]) - (let loop ([lo start][offset offset]) - (let ([hi (+ lo offset)]) - (with-handlers ([exn:fail? - (lambda (exn) - ; failed - must be between lo & hi - (find-between lo hi))]) - (seconds->date hi)) - ; succeeded; double offset again - (loop hi (* 2 offset)))))))) +;; Note: This code is correct until 2099 CE Gregorian - (define get-min-seconds - (let ([d (delay (find-extreme-date-seconds (current-seconds) -1))]) - (lambda () - (force d)))) - (define get-max-seconds - (let ([d (delay (find-extreme-date-seconds (current-seconds) 1))]) - (lambda () - (force d)))) +(define (date->julian/scalinger date) + (let ((day (date-day date)) + (month (date-month date)) + (year (date-year date))) + (let ((year (+ 4712 year))) + (let ((year (if (< month 3) (sub1 year) year))) + (let ((cycle-number (quotient year 4)) + (cycle-position (remainder year 4))) + (let ((base-day (+ (* 1461 cycle-number) (* 365 cycle-position)))) + (let ((month-day-number (case month + ((3) 0) + ((4) 31) + ((5) 61) + ((6) 92) + ((7) 122) + ((8) 153) + ((9) 184) + ((10) 214) + ((11) 245) + ((12) 275) + ((1) 306) + ((2) 337)))) + (let ((total-days (+ base-day month-day-number day))) + (let ((total-days/march-adjustment (+ total-days 59))) + (let ((gregorian-adjustment (cond + ((< year 1700) 11) + ((< year 1800) 12) + (else 13)))) + (let ((final-date (- total-days/march-adjustment + gregorian-adjustment))) + final-date))))))))))) - (define find-seconds - (lambda (sec min hour day month year) - (let ([signal-error - (lambda (msg) - (error 'find-secs (string-append - msg - " (inputs: ~a ~a ~a ~a ~a ~a)") - sec min hour day month year))]) - (let loop ([below-secs (get-min-seconds)] - [secs (floor (/ (+ (get-min-seconds) (get-max-seconds)) 2))] - [above-secs (get-max-seconds)]) - (let* ([date (seconds->date secs)] - [compare - (let loop ([inputs (list year month day - hour min sec)] - [tests (list (date-year date) - (date-month date) - (date-day date) - (date-hour date) - (date-minute date) - (date-second date))]) - (cond - [(null? inputs) 'equal] - [else (let ([input (car inputs)] - [test (car tests)]) - (if (= input test) - (loop (cdr inputs) (cdr tests)) - (if (<= input test) - 'input-smaller - 'test-smaller)))]))]) - ; (printf "~a ~a ~a~n" compare secs (date->string date)) - (cond - [(eq? compare 'equal) secs] - [(or (= secs below-secs) (= secs above-secs)) - (signal-error "non-existent date")] - [(eq? compare 'input-smaller) - (loop below-secs (floor (/ (+ secs below-secs) 2)) secs)] - [(eq? compare 'test-smaller) - (loop secs (floor (/ (+ above-secs secs) 2)) above-secs)])))))) - - ;; date->julian/scalinger : - ;; date -> number [julian-day] - - ;; Note: This code is correct until 2099 CE Gregorian - - (define (date->julian/scalinger date) - (let ((day (date-day date)) - (month (date-month date)) - (year (date-year date))) - (let ((year (+ 4712 year))) - (let ((year (if (< month 3) (sub1 year) year))) - (let ((cycle-number (quotient year 4)) - (cycle-position (remainder year 4))) - (let ((base-day (+ (* 1461 cycle-number) (* 365 cycle-position)))) - (let ((month-day-number (case month - ((3) 0) - ((4) 31) - ((5) 61) - ((6) 92) - ((7) 122) - ((8) 153) - ((9) 184) - ((10) 214) - ((11) 245) - ((12) 275) - ((1) 306) - ((2) 337)))) - (let ((total-days (+ base-day month-day-number day))) - (let ((total-days/march-adjustment (+ total-days 59))) - (let ((gregorian-adjustment (cond - ((< year 1700) 11) - ((< year 1800) 12) - (else 13)))) - (let ((final-date (- total-days/march-adjustment - gregorian-adjustment))) - final-date))))))))))) - - ;; julian/scalinger->string : - ;; number [julian-day] -> string [julian-day-format] - - (define (julian/scalinger->string julian-day) - (apply string-append - (cons "JD " - (reverse - (let loop ((reversed-digits (map number->string - (let loop ((jd julian-day)) - (if (zero? jd) null - (cons (remainder jd 10) - (loop (quotient jd 10)))))))) - (cond - ((or (null? reversed-digits) - (null? (cdr reversed-digits)) - (null? (cdr (cdr reversed-digits)))) - (list (apply string-append reversed-digits))) - (else (cons (apply string-append - (list " " - (caddr reversed-digits) - (cadr reversed-digits) - (car reversed-digits))) - (loop (cdr (cdr (cdr reversed-digits)))))))))))) - - ) +;; julian/scalinger->string : +;; number [julian-day] -> string [julian-day-format] +(define (julian/scalinger->string julian-day) + (apply string-append + (cons "JD " + (reverse + (let loop ((reversed-digits (map number->string + (let loop ((jd julian-day)) + (if (zero? jd) null + (cons (remainder jd 10) + (loop (quotient jd 10)))))))) + (cond + ((or (null? reversed-digits) + (null? (cdr reversed-digits)) + (null? (cdr (cdr reversed-digits)))) + (list (apply string-append reversed-digits))) + (else (cons (apply string-append + (list " " + (caddr reversed-digits) + (cadr reversed-digits) + (car reversed-digits))) + (loop (cdr (cdr (cdr reversed-digits)))))))))))) \ No newline at end of file diff --git a/collects/frtime/frp-snip.ss b/collects/frtime/frp-snip.ss index e384bb32e8..f04b375bd8 100644 --- a/collects/frtime/frp-snip.ss +++ b/collects/frtime/frp-snip.ss @@ -1,167 +1,168 @@ -(module frp-snip mzscheme - (require mzlib/class - mzlib/string - mzlib/list - mzlib/port +#lang scheme/base +(require scheme/class + (only-in mzlib/string expr->string) + scheme/list + scheme/port + + framework + + ;; FRP requires + + frtime/core/frp + (except-in frtime/lang-ext + undefined?) + (only-in frtime/lang-core + any-nested-reactivity? raise-reactivity) + + ;; MrEd require + (except-in mred send-event)) - framework - - ;; FRP requires - - frtime/core/frp - (all-except frtime/lang-ext undefined?) - (only frtime/lang-core any-nested-reactivity? raise-reactivity) +(define drs-eventspace #f) - ;; MrEd require - (all-except mred send-event)) - - (define drs-eventspace #f) - - (define (set-eventspace evspc) - (set! drs-eventspace evspc)) - - (define value-snip-copy% - (class string-snip% - (init-field current parent) - (inherit get-admin) - (define/public (set-current c) - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (lambda () - (set! current c) - (let ([admin (get-admin)]) - (when admin - (send admin needs-update this 0 0 2000 100))))))) - (define/override (draw dc x y left top right bottom dx dy draw-caret) - (send current draw dc x y left top right bottom dx dy draw-caret)) - (super-instantiate (" ")))) - - (define make-snip - (case-lambda - [(bhvr) - (make-object string-snip% - (let ([tmp (cond - [(behavior? bhvr) (value-now bhvr)] - [(event? bhvr) (signal-value bhvr)] - [else bhvr])]) - (cond - [(event-set? tmp) (format "#" - (event-set-events tmp) (event-set-time tmp))] - [(undefined? tmp) ""] - [else (expr->string tmp)])))] - [(bhvr super-render-fun) - (get-rendering (value-now bhvr) super-render-fun)])) - - (define value-snip% - (class string-snip% - (init-field bhvr) - (field [copies empty] - [loc-bhvr (proc->signal (lambda () (update)) bhvr)] - [current (make-snip bhvr)]) - - (define/override (copy) - (let ([ret (make-object value-snip-copy% current this)]) - (set! copies (cons ret copies)) - ret)) - - (define/public (update) - (set! current (make-snip bhvr)) - (for-each (lambda (copy) (send copy set-current current)) copies)) - - (super-instantiate (" ")))) - - (define dynamic-snip-copy% - (class editor-snip% - (init-field current parent) - (inherit get-editor) - (define/public (set-current c) - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (lambda () - (send (get-editor) lock #f) - (send (get-editor) delete 0 (send (get-editor) last-position)) - (for-each (lambda (thing) - (send (get-editor) insert thing - (send (get-editor) last-position) (send (get-editor) last-position))) - c) - (send (get-editor) lock #t))))) +(define (set-eventspace evspc) + (set! drs-eventspace evspc)) - (super-new - [editor (new scheme:text%)] - [with-border? #f] - [left-margin 0] - [right-margin 0] - [top-margin 0] - [bottom-margin 0]) - (set-current current))) +(define value-snip-copy% + (class string-snip% + (init-field current parent) + (inherit get-admin) + (define/public (set-current c) + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (lambda () + (set! current c) + (let ([admin (get-admin)]) + (when admin + (send admin needs-update this 0 0 2000 100))))))) + (define/override (draw dc x y left top right bottom dx dy draw-caret) + (send current draw dc x y left top right bottom dx dy draw-caret)) + (super-instantiate (" ")))) + +(define make-snip + (case-lambda + [(bhvr) + (make-object string-snip% + (let ([tmp (cond + [(behavior? bhvr) (value-now bhvr)] + [(event? bhvr) (signal-value bhvr)] + [else bhvr])]) + (cond + [(event-set? tmp) (format "#" + (event-set-events tmp) (event-set-time tmp))] + [(undefined? tmp) ""] + [else (expr->string tmp)])))] + [(bhvr super-render-fun) + (get-rendering (value-now bhvr) super-render-fun)])) + +(define value-snip% + (class string-snip% + (init-field bhvr) + (field [copies empty] + [loc-bhvr (proc->signal (lambda () (update)) bhvr)] + [current (make-snip bhvr)]) - (define dynamic-snip% - (class snip% - (init-field bhvr super-render-fun) - - (field [copies empty] - [loc-bhvr (proc->signal (lambda () (update)) bhvr)] - [current (make-snip bhvr super-render-fun)]) - - (define/override (copy) - (let ([ret (make-object dynamic-snip-copy% current this)]) - (set! copies (cons ret copies)) - ret)) - - (define/public (update) - (set! current (make-snip bhvr super-render-fun)) - (for-each (lambda (copy) (send copy set-current current)) copies)) - - (define/override (size-cache-invalid) - (for-each - (lambda (s) (send s size-cache-invalid)) - copies)) - - (define/override (get-extent dc x y w h descent space lspace rspace) - (send current get-extent dc x y w h descent space lspace rspace)) + (define/override (copy) + (let ([ret (make-object value-snip-copy% current this)]) + (set! copies (cons ret copies)) + ret)) + + (define/public (update) + (set! current (make-snip bhvr)) + (for-each (lambda (copy) (send copy set-current current)) copies)) + + (super-instantiate (" ")))) - (super-new))) +(define dynamic-snip-copy% + (class editor-snip% + (init-field current parent) + (inherit get-editor) + (define/public (set-current c) + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (lambda () + (send (get-editor) lock #f) + (send (get-editor) delete 0 (send (get-editor) last-position)) + (for-each (lambda (thing) + (send (get-editor) insert thing + (send (get-editor) last-position) (send (get-editor) last-position))) + c) + (send (get-editor) lock #t))))) + + (super-new + [editor (new scheme:text%)] + [with-border? #f] + [left-margin 0] + [right-margin 0] + [top-margin 0] + [bottom-margin 0]) + (set-current current))) - (define (render beh as-snip?) - (cond - [as-snip? (watch beh)] - [(undefined? (value-now beh)) ""] - [(behavior? beh) (format "#" (value-now beh))] - [(event? beh) (format "#" (event-set-events (signal-value beh)))] - [else beh])) - - (define (render/dynamic-snip val super-render-fun) - (if (behavior? val) - ; interesting case: - ; create a snip - ; each time val changes, recompute its rendering via super-render-fun - (make-object dynamic-snip% val super-render-fun) - ; easy case - (super-render-fun val))) - - (define (get-rendering val super-render-fun) - (let-values ([(in out) (make-pipe-with-specials)]) - (thread (lambda () (super-render-fun val out) (close-output-port out))) - (let loop ([chars empty]) - (let ([c (read-char-or-special in)]) - (if (eof-object? c) - (reverse (rest chars)) - (loop (cons c chars))))))) - - (define (watch beh super-render-fun) - (cond - [(undefined? beh) - (begin - (make-object string-snip% "") - ) - ] - [(event? beh) - (make-object value-snip% beh)] - [(or (behavior? beh) (any-nested-reactivity? beh)) - (make-object dynamic-snip% (raise-reactivity beh) super-render-fun)] - [(signal? beh) - (make-object dynamic-snip% beh super-render-fun)] - [else beh])) - - (provide (all-defined)) - ) +(define dynamic-snip% + (class snip% + (init-field bhvr super-render-fun) + + (field [copies empty] + [loc-bhvr (proc->signal (lambda () (update)) bhvr)] + [current (make-snip bhvr super-render-fun)]) + + (define/override (copy) + (let ([ret (make-object dynamic-snip-copy% current this)]) + (set! copies (cons ret copies)) + ret)) + + (define/public (update) + (set! current (make-snip bhvr super-render-fun)) + (for-each (lambda (copy) (send copy set-current current)) copies)) + + (define/override (size-cache-invalid) + (for-each + (lambda (s) (send s size-cache-invalid)) + copies)) + + (define/override (get-extent dc x y w h descent space lspace rspace) + (send current get-extent dc x y w h descent space lspace rspace)) + + (super-new))) + +(define (render beh as-snip?) + (cond + [as-snip? (watch beh)] + [(undefined? (value-now beh)) ""] + [(behavior? beh) (format "#" (value-now beh))] + [(event? beh) (format "#" (event-set-events (signal-value beh)))] + [else beh])) + +(define (render/dynamic-snip val super-render-fun) + (if (behavior? val) + ; interesting case: + ; create a snip + ; each time val changes, recompute its rendering via super-render-fun + (make-object dynamic-snip% val super-render-fun) + ; easy case + (super-render-fun val))) + +(define (get-rendering val super-render-fun) + (let-values ([(in out) (make-pipe-with-specials)]) + (thread (lambda () (super-render-fun val out) (close-output-port out))) + (let loop ([chars empty]) + (let ([c (read-char-or-special in)]) + (if (eof-object? c) + (reverse (rest chars)) + (loop (cons c chars))))))) + +(define (watch beh super-render-fun) + (cond + [(undefined? beh) + (begin + (make-object string-snip% "") + ) + ] + [(event? beh) + (make-object value-snip% beh)] + [(or (behavior? beh) (any-nested-reactivity? beh)) + (make-object dynamic-snip% (raise-reactivity beh) super-render-fun)] + [(signal? beh) + (make-object dynamic-snip% beh super-render-fun)] + [else beh])) + +(provide (all-defined-out)) \ No newline at end of file diff --git a/collects/frtime/frtime-tool.ss b/collects/frtime/frtime-tool.ss index f18eec8a96..8e54f554cc 100644 --- a/collects/frtime/frtime-tool.ss +++ b/collects/frtime/frtime-tool.ss @@ -1,94 +1,94 @@ +#lang scheme/base +(require scheme/unit + scheme/class + scheme/bool + mred + (only-in mzlib/etc identity) + scheme/list + drscheme/tool + string-constants) -(module frtime-tool mzscheme - (require mzlib/unit - mzlib/class - mred - mzlib/etc - mzlib/list - drscheme/tool - string-constants) - - (provide tool@) +(provide tool@) - (define tool@ - (unit - (import drscheme:tool^) - (export drscheme:tool-exports^) - - (define big-frtime-language% - (class* object% (drscheme:language:simple-module-based-language<%>) - (define/public (get-language-numbers) - '(1000 -400)) - (define/public (get-language-position) - (list (string-constant experimental-languages) "FrTime")) - (define/public (get-module) - 'frtime/frtime-big) - (define/public (get-one-line-summary) - "Language for functional programming of event-driven systems") - (define/public (get-language-url) #f) - (define/public (get-reader) - (lambda (name port) - (let ([v (read-syntax name port)]) - (if (eof-object? v) - v - (namespace-syntax-introduce v))))) - (super-instantiate ()))) - - (define (weak-member obj lis) - (let ([cmp (lambda (v) (eq? v obj))]) - (let loop ([lis lis]) - (and (cons? lis) - (or - (cond - [(weak-box-value (first lis)) => cmp] - [else false]) - (loop (rest lis))))))) - - (define (watch watch-list value super-render-fun) - (foldl - (lambda (wb acc) - (cond - [(weak-box-value wb) - => (lambda (f) (f acc super-render-fun))] - [else acc])) - value - watch-list)) - - (define (make-frtime-language base) - (class (drscheme:language:module-based-language->language-mixin - (drscheme:language:simple-module-based-language->module-based-language-mixin - base)) - (field (watch-list empty)) - (inherit get-language-position) - (define/override (get-language-name) - "FrTime") - (define/override (on-execute settings run-in-user-thread) - (let ([drs-eventspace (current-eventspace)]) - (super on-execute settings run-in-user-thread) - (run-in-user-thread - (lambda () - (let ([new-watch (namespace-variable-value 'watch)] - [set-evspc (namespace-variable-value 'set-eventspace)]) - (set-evspc drs-eventspace) - (set! watch-list - ((if (weak-member new-watch watch-list) - identity - (lambda (r) (cons (make-weak-box new-watch) r))) - (filter weak-box-value watch-list)))))))) - - ;; pass (lambda (v) (super render-value(/format) v settings width port)) - ;; to watcher - (override render-value/format render-value) - (define (render-value/format value settings port width) - (super render-value/format (watch watch-list value (lambda (v prt) (render-value/format v settings prt width))) - settings port width)) - (define (render-value value settings port) - (super render-value (watch watch-list value (lambda (v prt) (render-value settings prt))) - settings port)) - (define/override (use-namespace-require/copy?) #t) - (super-instantiate ()))) - - (define (phase1) (void)) - (define (phase2) - (drscheme:language-configuration:add-language - (make-object ((drscheme:language:get-default-mixin) (make-frtime-language big-frtime-language%)))))))) +(define tool@ + (unit + (import drscheme:tool^) + (export drscheme:tool-exports^) + + (define big-frtime-language% + (class* object% (drscheme:language:simple-module-based-language<%>) + (define/public (get-language-numbers) + '(1000 -400)) + (define/public (get-language-position) + (list (string-constant experimental-languages) "FrTime")) + (define/public (get-module) + 'frtime/frtime-big) + (define/public (get-one-line-summary) + "Language for functional programming of event-driven systems") + (define/public (get-language-url) #f) + (define/public (get-reader) + (lambda (name port) + (let ([v (read-syntax name port)]) + (if (eof-object? v) + v + (namespace-syntax-introduce v))))) + (super-instantiate ()))) + + (define (weak-member obj lis) + (let ([cmp (lambda (v) (eq? v obj))]) + (let loop ([lis lis]) + (and (cons? lis) + (or + (cond + [(weak-box-value (first lis)) => cmp] + [else false]) + (loop (rest lis))))))) + + (define (watch watch-list value super-render-fun) + (foldl + (lambda (wb acc) + (cond + [(weak-box-value wb) + => (lambda (f) (f acc super-render-fun))] + [else acc])) + value + watch-list)) + + (define (make-frtime-language base) + (class (drscheme:language:module-based-language->language-mixin + (drscheme:language:simple-module-based-language->module-based-language-mixin + base)) + (field (watch-list empty)) + (inherit get-language-position) + (define/override (get-language-name) + "FrTime") + (define/override (on-execute settings run-in-user-thread) + (let ([drs-eventspace (current-eventspace)]) + (super on-execute settings run-in-user-thread) + (run-in-user-thread + (lambda () + (let ([new-watch (namespace-variable-value 'watch)] + [set-evspc (namespace-variable-value 'set-eventspace)]) + (set-evspc drs-eventspace) + (set! watch-list + ((if (weak-member new-watch watch-list) + identity + (lambda (r) (cons (make-weak-box new-watch) r))) + (filter weak-box-value watch-list)))))))) + + ;; pass (lambda (v) (super render-value(/format) v settings width port)) + ;; to watcher + (override render-value/format render-value) + (define (render-value/format value settings port width) + (super render-value/format (watch watch-list value (lambda (v prt) (render-value/format v settings prt width))) + settings port width)) + (define (render-value value settings port) + (super render-value (watch watch-list value (lambda (v prt) (render-value settings prt))) + settings port)) + (define/override (use-namespace-require/copy?) #t) + (super-instantiate ()))) + + (define (phase1) (void)) + (define (phase2) + (drscheme:language-configuration:add-language + (make-object ((drscheme:language:get-default-mixin) (make-frtime-language big-frtime-language%))))))) \ No newline at end of file diff --git a/collects/frtime/graphics-sig.ss b/collects/frtime/graphics-sig.ss index fde1fde1d8..3dab37dcb2 100644 --- a/collects/frtime/graphics-sig.ss +++ b/collects/frtime/graphics-sig.ss @@ -1,72 +1,68 @@ -(module graphics-sig mzscheme - (require mzlib/unit) +#lang scheme +(require scheme/unit) - (provide graphics^ graphics:posn-less^ graphics:posn^) - - (define-signature graphics:posn^ - (make-posn posn? posn-x posn-y set-posn-x! set-posn-y!)) - - (define-signature graphics:posn-less^ - (viewport? - - sixkey-value sixkey-shift sixkey-control sixkey-meta sixkey-alt - - sixmouse-x sixmouse-y sixmouse-left? sixmouse-middle? sixmouse-right? - sixmouse? - make-sixmouse - - open-graphics - close-graphics - graphics-open? - - make-rgb - rgb-blue rgb-red rgb-green - change-color - rgb? - - open-viewport - open-pixmap - close-viewport - - query-mouse-posn - - viewport-mouse-events - viewport-key-events - - clear-viewport draw-viewport flip-viewport - - draw-line clear-line flip-line - draw-pixel clear-pixel flip-pixel - get-pixel get-color-pixel test-pixel - - draw-rectangle clear-rectangle flip-rectangle - draw-arc draw-solid-arc - draw-ellipse clear-ellipse flip-ellipse - draw-polygon clear-polygon flip-polygon - draw-solid-rectangle clear-solid-rectangle flip-solid-rectangle - draw-solid-ellipse clear-solid-ellipse flip-solid-ellipse - draw-solid-polygon clear-solid-polygon flip-solid-polygon - - get-string-size - - draw-string clear-string flip-string - - draw-pixmap-posn - draw-pixmap - save-pixmap - - copy-viewport - - default-display-is-color? - - viewport->snip - - viewport-dc viewport-buffer-dc)) - - (define-signature graphics^ - ((open graphics:posn-less^) - (open graphics:posn^))) -) +(provide graphics^ graphics:posn-less^ graphics:posn^) +(define-signature graphics:posn^ + (make-posn posn? posn-x posn-y set-posn-x! set-posn-y!)) +(define-signature graphics:posn-less^ + (viewport? + + sixkey-value sixkey-shift sixkey-control sixkey-meta sixkey-alt + + sixmouse-x sixmouse-y sixmouse-left? sixmouse-middle? sixmouse-right? + sixmouse? + make-sixmouse + + open-graphics + close-graphics + graphics-open? + + make-rgb + rgb-blue rgb-red rgb-green + change-color + rgb? + + open-viewport + open-pixmap + close-viewport + + query-mouse-posn + + viewport-mouse-events + viewport-key-events + + clear-viewport draw-viewport flip-viewport + + draw-line clear-line flip-line + draw-pixel clear-pixel flip-pixel + get-pixel get-color-pixel test-pixel + + draw-rectangle clear-rectangle flip-rectangle + draw-arc draw-solid-arc + draw-ellipse clear-ellipse flip-ellipse + draw-polygon clear-polygon flip-polygon + draw-solid-rectangle clear-solid-rectangle flip-solid-rectangle + draw-solid-ellipse clear-solid-ellipse flip-solid-ellipse + draw-solid-polygon clear-solid-polygon flip-solid-polygon + + get-string-size + + draw-string clear-string flip-string + + draw-pixmap-posn + draw-pixmap + save-pixmap + + copy-viewport + + default-display-is-color? + + viewport->snip + + viewport-dc viewport-buffer-dc)) +(define-signature graphics^ + ((open graphics:posn-less^) + (open graphics:posn^))) \ No newline at end of file diff --git a/collects/frtime/graphics-unit.ss b/collects/frtime/graphics-unit.ss index 153f664e0b..795e405260 100644 --- a/collects/frtime/graphics-unit.ss +++ b/collects/frtime/graphics-unit.ss @@ -1,15 +1,14 @@ -(module graphics-unit mzscheme - (require mzlib/unit - mred/mred-sig - "graphics-sig.ss" - "graphics-posn-less-unit.ss") - (provide graphics@) +#lang scheme +(require scheme/unit + mred/mred-sig + "graphics-sig.ss" + "graphics-posn-less-unit.ss") +(provide graphics@) - (define-unit posn@ (import) (export graphics:posn^) - (define-struct posn (x y))) - - (define-compound-unit/infer graphics@ - (import mred^) - (export graphics:posn^ graphics:posn-less^) - (link posn@ graphics-posn-less@))) +(define-unit posn@ (import) (export graphics:posn^) + (define-struct posn (x y) #:mutable)) +(define-compound-unit/infer graphics@ + (import mred^) + (export graphics:posn^ graphics:posn-less^) + (link posn@ graphics-posn-less@)) \ No newline at end of file diff --git a/collects/frtime/graphics.ss b/collects/frtime/graphics.ss index 911e1d3644..d9e4ee3f65 100644 --- a/collects/frtime/graphics.ss +++ b/collects/frtime/graphics.ss @@ -1,9 +1,9 @@ -(module graphics mzscheme - (require mzlib/unit - mred/mred-sig - mred - "graphics-sig.ss" - "graphics-unit.ss") - (provide-signature-elements graphics:posn^ graphics:posn-less^) +#lang scheme +(require scheme/unit + mred/mred-sig + mred + "graphics-sig.ss" + "graphics-unit.ss") +(provide-signature-elements graphics:posn^ graphics:posn-less^) - (define-values/invoke-unit/infer graphics@)) +(define-values/invoke-unit/infer graphics@) \ No newline at end of file diff --git a/collects/frtime/lowered-equivs.ss b/collects/frtime/lowered-equivs.ss index 731e5406f1..5fb120aef8 100644 --- a/collects/frtime/lowered-equivs.ss +++ b/collects/frtime/lowered-equivs.ss @@ -1,115 +1,115 @@ ;; This module defines all the logic necessary for working with lowered ;; equivalents at the syntactic level. That is, it treats functions simply ;; as syntactic identifiers. -(module lowered-equivs mzscheme - (provide (all-defined)) - (require mzlib/list) - (require (only srfi/1 any)) +#lang scheme +(provide (except-out (all-defined-out) + module-identifier=?)) +(require (only-in srfi/1 any)) - (define lowered-equiv-suffix ":lowered-equiv") - - ;; Given an identifier for a normal binding, return the identifier - ;; to be used for the lowered equivalent of that binding. - (define (make-lowered-equiv-id id-stx) - (datum->syntax-object +(define module-identifier=? free-identifier=?) + +(define lowered-equiv-suffix ":lowered-equiv") + +;; Given an identifier for a normal binding, return the identifier +;; to be used for the lowered equivalent of that binding. +(define (make-lowered-equiv-id id-stx) + (datum->syntax + id-stx + (string->symbol + (format "~a~a" (syntax-e id-stx) lowered-equiv-suffix)))) + +;; does the given string end with the given suffix? +(define (string-ends-with str suffix) + (string=? (substring str (max 0 (- (string-length str) + (string-length suffix)))) + suffix)) + +;; is the given identifier a lowered equiv identifier? +(define (lowered-equiv-id? id-stx) + (and (identifier? id-stx) + (string-ends-with (symbol->string (syntax-e id-stx)) + lowered-equiv-suffix))) + +;; strip the lowered-equiv suffix from an identifier +(define (lowered-equiv-id->lifted-id id-stx) + (let ([name (symbol->string (syntax-e id-stx))]) + (datum->syntax id-stx (string->symbol - (format "~a~a" (syntax-e id-stx) lowered-equiv-suffix)))) + (substring name 0 (- (string-length name) + (string-length lowered-equiv-suffix))))))) - ;; does the given string end with the given suffix? - (define (string-ends-with str suffix) - (string=? (substring str (max 0 (- (string-length str) - (string-length suffix)))) - suffix)) +;; Exception used to indicate that an expression cannot be lowered because +;; it has no lowered equivalent. +(define-struct exn:no-lowered-equiv (reason)) - ;; is the given identifier a lowered equiv identifier? - (define (lowered-equiv-id? id-stx) - (and (identifier? id-stx) - (string-ends-with (symbol->string (syntax-e id-stx)) - lowered-equiv-suffix))) - - ;; strip the lowered-equiv suffix from an identifier - (define (lowered-equiv-id->lifted-id id-stx) - (let ([name (symbol->string (syntax-e id-stx))]) - (datum->syntax-object - id-stx - (string->symbol - (substring name 0 (- (string-length name) - (string-length lowered-equiv-suffix))))))) - - ;; Exception used to indicate that an expression cannot be lowered because - ;; it has no lowered equivalent. - (define-struct exn:no-lowered-equiv (reason)) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Equiv maps translate function names to the name of a lowered equivalent. - ;; Equiv maps are represented as a list of (func . lowered-equiv) pairs. - - ;; empty equiv map - (define (empty-equiv-map) - (list)) - - ;; add a new func/lowered-equiv mapping to an equiv map (overwrites any - ;; existing mapping) - (define (add-equiv-map old-equiv-map new-func new-lowered-func) - (cons (cons new-func new-lowered-func) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Equiv maps translate function names to the name of a lowered equivalent. +;; Equiv maps are represented as a list of (func . lowered-equiv) pairs. + +;; empty equiv map +(define (empty-equiv-map) + (list)) + +;; add a new func/lowered-equiv mapping to an equiv map (overwrites any +;; existing mapping) +(define (add-equiv-map old-equiv-map new-func new-lowered-func) + (cons (cons new-func new-lowered-func) + old-equiv-map)) + +;; remove a func/lowered-equiv mapping from an equiv map (no effect if +;; the func isn't actually in the mapping) +(define (del-equiv-map old-equiv-map func-to-remove) + (filter (lambda (pair) + (not (module-identifier=? (car pair) func-to-remove))) old-equiv-map)) - - ;; remove a func/lowered-equiv mapping from an equiv map (no effect if - ;; the func isn't actually in the mapping) - (define (del-equiv-map old-equiv-map func-to-remove) - (filter (lambda (pair) - (not (module-identifier=? (car pair) func-to-remove))) - old-equiv-map)) - - ;; remove a list of funcs from an equiv map - (define (del-equiv-map* old-equiv-map ids-to-remove) - (foldl del-equiv-map old-equiv-map ids-to-remove)) - - ;; Returns the lowered-equiv for a function, or #f if there is none. - (define (lookup-lowered-equiv equiv-map func) - (if (null? equiv-map) - #f - (if (module-identifier=? (caar equiv-map) func) - (cdar equiv-map) - (lookup-lowered-equiv (cdr equiv-map) func)))) - - ;; Returns the lowered-equiv for a function, or throws exn:no-lowered-equiv. - (define (get-lowered-equiv equiv-map func) - (let ([ret (lookup-lowered-equiv equiv-map func)]) - (if ret - ret - (raise (make-exn:no-lowered-equiv - (format "no lowered equiv for ~s" (syntax-object->datum func))))))) - ;; convert syntax of the form ((func lowered-equiv) ...) to an equiv map - (define (stx-to-equiv-map stx) - (syntax-case stx () - (() (empty-equiv-map)) - (((lifted lowered) rest ...) - (add-equiv-map (stx-to-equiv-map #'(rest ...)) #'lifted #'lowered)))) - - ;; convert an equiv map to syntax of the form ((func lowered-equiv) ...) - (define (equiv-map-to-stx equiv-map) - (datum->syntax-object #'here - (map (lambda (pair) (list (car pair) (cdr pair))) - equiv-map))) +;; remove a list of funcs from an equiv map +(define (del-equiv-map* old-equiv-map ids-to-remove) + (foldl del-equiv-map old-equiv-map ids-to-remove)) - ;; combine two equiv maps - (define (union-equiv-maps . equiv-maps) - (apply append equiv-maps)) - - ;; convert a list of symbols to an equiv map, by searching for symbols - ;; that have a matching lowered equivalent symbol. All other symbols - ;; are ignored. - (define (symbol-list-to-equiv-map symbol-list) - (foldl (lambda (func equiv-map) - (if (lowered-equiv-id? func) - (add-equiv-map - equiv-map - (lowered-equiv-id->lifted-id func) func) - equiv-map)) - (empty-equiv-map) - symbol-list)) - ) +;; Returns the lowered-equiv for a function, or #f if there is none. +(define (lookup-lowered-equiv equiv-map func) + (if (null? equiv-map) + #f + (if (module-identifier=? (caar equiv-map) func) + (cdar equiv-map) + (lookup-lowered-equiv (cdr equiv-map) func)))) +;; Returns the lowered-equiv for a function, or throws exn:no-lowered-equiv. +(define (get-lowered-equiv equiv-map func) + (let ([ret (lookup-lowered-equiv equiv-map func)]) + (if ret + ret + (raise (make-exn:no-lowered-equiv + (format "no lowered equiv for ~s" (syntax->datum func))))))) + +;; convert syntax of the form ((func lowered-equiv) ...) to an equiv map +(define (stx-to-equiv-map stx) + (syntax-case stx () + (() (empty-equiv-map)) + (((lifted lowered) rest ...) + (add-equiv-map (stx-to-equiv-map #'(rest ...)) #'lifted #'lowered)))) + +;; convert an equiv map to syntax of the form ((func lowered-equiv) ...) +(define (equiv-map-to-stx equiv-map) + (datum->syntax #'here + (map (lambda (pair) (list (car pair) (cdr pair))) + equiv-map))) + +;; combine two equiv maps +(define (union-equiv-maps . equiv-maps) + (apply append equiv-maps)) + +;; convert a list of symbols to an equiv map, by searching for symbols +;; that have a matching lowered equivalent symbol. All other symbols +;; are ignored. +(define (symbol-list-to-equiv-map symbol-list) + (foldl (lambda (func equiv-map) + (if (lowered-equiv-id? func) + (add-equiv-map + equiv-map + (lowered-equiv-id->lifted-id func) func) + equiv-map)) + (empty-equiv-map) + symbol-list)) \ No newline at end of file