MrEd_100.txt
original commit: 4a325ca403f0a0dac339262d6fedcf42170d56b9
This commit is contained in:
Matthew Flatt
parent
22f8c90ed0
commit
4ed8787871
BIN
collects/mysterx/dlls/myssink.dll
Normal file
BIN
collects/mysterx/dlls/myssink.dll
Normal file
Binary file not shown.
1380
collects/mysterx/doc.txt
Normal file
1380
collects/mysterx/doc.txt
Normal file
File diff suppressed because it is too large
Load Diff
27
collects/mysterx/info.ss
Normal file
27
collects/mysterx/info.ss
Normal file
|
|
@ -0,0 +1,27 @@
|
|||
;; info.ss for mysterx collection
|
||||
|
||||
(lambda (request failure-thunk)
|
||||
(case request
|
||||
[(name) "MysterX"]
|
||||
[(compile-prefix)
|
||||
(if (not (eq? (system-type) 'windows))
|
||||
(begin
|
||||
(fprintf (current-error-port)
|
||||
"Error: can't install MysterX on non-Windows machine~n")
|
||||
(failure-thunk))
|
||||
`(begin
|
||||
(current-require-relative-collection (list "mysterx"))
|
||||
(require-library "macro.ss")
|
||||
(require-library "cores.ss")
|
||||
(require-relative-library "mysterxu.ss")
|
||||
(let ([winsys-dir (find-system-path 'sys-dir)])
|
||||
(if winsys-dir
|
||||
(for-each
|
||||
(lambda (dll)
|
||||
(system
|
||||
(format "~a\\REGSVR32 \"~a\\dlls\\~a\""
|
||||
winsys-dir (current-directory) dll)))
|
||||
'(myspage.dll myssink.dll))
|
||||
(fprintf (current-error-port)
|
||||
"Warning: Can't run REGSVR32 on libraries~n")))))]
|
||||
[else (failure-thunk)]))
|
||||
182
collects/mysterx/mxdemo.ss
Normal file
182
collects/mysterx/mxdemo.ss
Normal file
|
|
@ -0,0 +1,182 @@
|
|||
;;; mxdemo.ss -- demo program for MysterX
|
||||
|
||||
;;; requires Office 97 to be installed for Calendar Control to work
|
||||
|
||||
(require-library "mysterx.ss" "mysterx")
|
||||
|
||||
; the document with the calendar
|
||||
(define caldoc (make-object mx-document% "Demo or die!" 350 400 100 100 '()))
|
||||
|
||||
(send caldoc insert-html
|
||||
(string-append
|
||||
"<H1 id=\"mx-header\">MysterX Demo</H1>"
|
||||
"<p>"
|
||||
"<hr>"
|
||||
"<p>"
|
||||
(coclass->html "Calendar Control 8.0" 300 200)
|
||||
"<p>"
|
||||
"<H3 id=\"event-header\"></H3>"))
|
||||
|
||||
(define cal (car (send caldoc objects)))
|
||||
|
||||
; the control panel document
|
||||
(define ctrldoc (make-object mx-document% "Control Panel" 180 350 600 300 '()))
|
||||
|
||||
(send ctrldoc insert-html
|
||||
(string-append
|
||||
"<table align = center>"
|
||||
|
||||
"<caption id=\"Caption\"><b>Keypress here</b></caption>"
|
||||
|
||||
"<colgroup align=left>"
|
||||
"<colgroup align=center>"
|
||||
"<colgroup align=right>"
|
||||
|
||||
"<tr>"
|
||||
"<td><BUTTON id=\"Yesterday\" style=\"color: blue\"><----</BUTTON></td>"
|
||||
"<td><b>Day</b></td>"
|
||||
"<td><BUTTON id=\"Tomorrow\" style=\"color: red\">----></BUTTON></td>"
|
||||
"</tr>"
|
||||
|
||||
"<tr>"
|
||||
"<td><BUTTON id=\"Last-month\" style=\"color: green\"><----</BUTTON></td>"
|
||||
"<td><b>Month</b></td>"
|
||||
"<td><BUTTON id=\"Next-month\" style=\"color: indigo\">----></BUTTON></td>"
|
||||
"</tr>"
|
||||
|
||||
"<tr>"
|
||||
"<td><BUTTON id=\"Last-year\" style=\"color: yellow\"><----</BUTTON></td>"
|
||||
"<td><b>Year</b></td>"
|
||||
"<td><BUTTON id=\"Next-year\" style=\"color: purple\">----></BUTTON></td>"
|
||||
"</tr>"
|
||||
|
||||
"</table>"
|
||||
|
||||
"<table align=center>"
|
||||
|
||||
"<td><BUTTON id=\"Today\">Today</BUTTON></td>"
|
||||
|
||||
"</table>"
|
||||
|
||||
"<hr>"
|
||||
|
||||
"<table align=center>"
|
||||
|
||||
"<tr>"
|
||||
"<td><BUTTON id=\"Hide\">Hide</BUTTON></td>"
|
||||
"<td><BUTTON id=\"Show\">Show</BUTTON></td>"
|
||||
"</tr>"
|
||||
|
||||
"</table>"
|
||||
|
||||
"<table align=center>"
|
||||
|
||||
"<td><BUTTON id=\"Rub-me\">Rub me!</BUTTON></td>"
|
||||
|
||||
"</table>"
|
||||
|
||||
"<table align=center>"
|
||||
|
||||
"<td><BUTTON id=\"About\">About</BUTTON></td>"
|
||||
|
||||
"</table>"
|
||||
|
||||
"<p>"
|
||||
|
||||
"<table align=center>"
|
||||
|
||||
"<td id=\"event-reflector\">Click on the calendar</td>"
|
||||
|
||||
"</table>"))
|
||||
|
||||
(define reflector (send ctrldoc find-element "TD" "event-reflector"))
|
||||
|
||||
(com-register-event-handler
|
||||
cal "Click"
|
||||
(lambda ()
|
||||
(send reflector set-color! "white")
|
||||
(send reflector set-background-color! "blue")
|
||||
(thread
|
||||
(lambda ()
|
||||
(sleep 0.25)
|
||||
(send reflector set-color! "black")
|
||||
(send reflector set-background-color! "white")))))
|
||||
|
||||
(define (about-handler ev)
|
||||
(when (send ev click?)
|
||||
(com-invoke cal "AboutBox")))
|
||||
|
||||
(define (hide-handler ev)
|
||||
(when (send ev click?)
|
||||
(send caldoc show #f)))
|
||||
|
||||
(define (show-handler ev)
|
||||
(when (send ev click?)
|
||||
(send caldoc show #t)))
|
||||
|
||||
(define rub-me-handler
|
||||
(let ([count 0])
|
||||
(lambda (ev)
|
||||
(when (send ev mousemove?)
|
||||
(printf "mousemove #~a, but who's counting?~n" count)
|
||||
(set! count (add1 count))))))
|
||||
|
||||
(define (today-handler ev)
|
||||
(when (send ev click?)
|
||||
(com-invoke cal "Today")))
|
||||
|
||||
(define (yesterday-handler ev)
|
||||
(when (send ev click?)
|
||||
(com-invoke cal "PreviousDay")))
|
||||
|
||||
(define (tomorrow-handler ev)
|
||||
(when (send ev click?)
|
||||
(com-invoke cal "NextDay")))
|
||||
|
||||
(define (last-month-handler ev)
|
||||
(when (send ev click?)
|
||||
(com-invoke cal "PreviousMonth")))
|
||||
|
||||
(define (next-month-handler ev)
|
||||
(when (send ev click?)
|
||||
(com-invoke cal "NextMonth")))
|
||||
|
||||
(define (last-year-handler ev)
|
||||
(when (send ev click?)
|
||||
(com-invoke cal "PreviousYear")))
|
||||
|
||||
(define (next-year-handler ev)
|
||||
(when (send ev click?)
|
||||
(com-invoke cal "NextYear")))
|
||||
|
||||
(define button-handlers
|
||||
`(("About" ,about-handler)
|
||||
("Hide" ,hide-handler)
|
||||
("Show" ,show-handler)
|
||||
("Rub-me" ,rub-me-handler)
|
||||
("Today" ,today-handler)
|
||||
("Yesterday" ,yesterday-handler)
|
||||
("Tomorrow" ,tomorrow-handler)
|
||||
("Last-month" ,last-month-handler)
|
||||
("Next-month" ,next-month-handler)
|
||||
("Last-year" ,last-year-handler)
|
||||
("Next-year" ,next-year-handler)))
|
||||
|
||||
(send ctrldoc register-event-handler
|
||||
(send ctrldoc find-element "CAPTION" "Caption")
|
||||
(lambda (ev)
|
||||
(when (send ev keypress?)
|
||||
(printf "ooh that tickles~n"))))
|
||||
|
||||
(for-each
|
||||
(lambda (sym-handler)
|
||||
(send ctrldoc register-event-handler
|
||||
(send ctrldoc find-element
|
||||
"BUTTON" ; tag
|
||||
(car sym-handler)) ; id
|
||||
(cadr sym-handler))) ; handler
|
||||
button-handlers)
|
||||
|
||||
(send ctrldoc handle-events)
|
||||
|
||||
|
||||
7
collects/mysterx/mysterx.ss
Normal file
7
collects/mysterx/mysterx.ss
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
;; mysterx.ss
|
||||
|
||||
(require-library "mysterxu.ss" "mysterx")
|
||||
|
||||
(define-values/invoke-unit/sig
|
||||
mysterx:mysterx^
|
||||
mysterx@)
|
||||
862
collects/mysterx/mysterxe.ss
Normal file
862
collects/mysterx/mysterxe.ss
Normal file
|
|
@ -0,0 +1,862 @@
|
|||
;; mysterxe.ss
|
||||
|
||||
(require-library "xml.ss" "xml")
|
||||
|
||||
(unit/sig mysterx:mysterx^
|
||||
(import
|
||||
mzlib:function^
|
||||
mzlib:string^
|
||||
[mxprims : mysterx:prims^]
|
||||
[xml : xml^])
|
||||
|
||||
(define com-invoke mxprims:com-invoke)
|
||||
(define com-set-property! mxprims:com-set-property!)
|
||||
(define com-get-property mxprims:com-get-property)
|
||||
(define com-methods mxprims:com-methods)
|
||||
(define com-get-properties mxprims:com-get-properties)
|
||||
(define com-set-properties mxprims:com-set-properties)
|
||||
(define com-events mxprims:com-events)
|
||||
(define com-method-type mxprims:com-method-type)
|
||||
(define com-get-property-type mxprims:com-get-property-type)
|
||||
(define com-set-property-type mxprims:com-set-property-type)
|
||||
(define com-event-type mxprims:com-event-type)
|
||||
(define com-object-type mxprims:com-object-type)
|
||||
(define com-is-a? mxprims:com-is-a?)
|
||||
(define com-help mxprims:com-help)
|
||||
(define com-register-event-handler mxprims:com-register-event-handler)
|
||||
(define com-unregister-event-handler mxprims:com-unregister-event-handler)
|
||||
(define com-all-coclasses mxprims:com-all-coclasses)
|
||||
(define com-all-controls mxprims:com-all-controls)
|
||||
(define coclass->html mxprims:coclass->html)
|
||||
(define cocreate-instance mxprims:cocreate-instance)
|
||||
(define com-object-eq? mxprims:com-object-eq?)
|
||||
(define com-object? mxprims:com-object?)
|
||||
(define com-omit mxprims:com-omit)
|
||||
|
||||
(define html-sem (make-semaphore 1)) ; protects HTML insertions
|
||||
(define html-wait (lambda () (semaphore-wait html-sem)))
|
||||
(define html-post (lambda () (semaphore-post html-sem)))
|
||||
|
||||
(define (xexp->string xexp)
|
||||
(lambda (xexp)
|
||||
(parameterize ([xml:empty-tag-shorthand #f])
|
||||
(let* ([port (open-output-string)]
|
||||
[xml (xml:xexpr->xml xexp)])
|
||||
(xml:write-xml/content xml port)
|
||||
(get-output-string port)))))
|
||||
|
||||
(define mx-element%
|
||||
(class object% (document dhtml-element)
|
||||
|
||||
(private
|
||||
[elt dhtml-element]
|
||||
[doc document])
|
||||
|
||||
(public
|
||||
[insert-html
|
||||
(lambda (s)
|
||||
(dynamic-wind
|
||||
html-wait
|
||||
(lambda () (mxprims:element-insert-html elt s))
|
||||
html-post))]
|
||||
[append-html
|
||||
(lambda (s)
|
||||
(dynamic-wind
|
||||
html-wait
|
||||
(lambda () (mxprims:element-append-html elt s))
|
||||
html-post))]
|
||||
[replace-html
|
||||
(lambda (s)
|
||||
(dynamic-wind
|
||||
html-wait
|
||||
(lambda () (mxprims:element-replace-html elt s))
|
||||
html-post))]
|
||||
[insert-text
|
||||
(lambda (s)
|
||||
(mxprims:element-insert-text elt s))]
|
||||
[append-text
|
||||
(lambda (s)
|
||||
(mxprims:element-append-text elt s))]
|
||||
[insert-object
|
||||
(opt-lambda (object width height [size 'pixels])
|
||||
(dynamic-wind
|
||||
html-wait
|
||||
(lambda ()
|
||||
(let ([old-objects (mxprims:document-objects doc)])
|
||||
(mxprims:element-insert-html
|
||||
elt
|
||||
(coclass->html object width height size))
|
||||
(let* ([new-objects (mxprims:document-objects doc)]
|
||||
[obj (car (remove* old-objects new-objects
|
||||
com-object-eq?))])
|
||||
(mxprims:com-register-object obj)
|
||||
obj)))
|
||||
html-post))]
|
||||
[append-object
|
||||
(opt-lambda (object width height [size 'pixels])
|
||||
(dynamic-wind
|
||||
html-wait
|
||||
(lambda ()
|
||||
(let* ([old-objects (mxprims:document-objects doc)])
|
||||
(mxprims:element-append-html
|
||||
elt
|
||||
(coclass->html object width height size))
|
||||
(let* ([new-objects (mxprims:document-objects doc)]
|
||||
[obj (car (remove* old-objects
|
||||
new-objects
|
||||
com-object-eq?))])
|
||||
(mxprims:com-register-object obj)
|
||||
obj)))
|
||||
html-post))]
|
||||
[attribute
|
||||
(lambda (s)
|
||||
(mxprims:element-attribute elt s))]
|
||||
[set-attribute!
|
||||
(lambda (a v)
|
||||
(mxprims:element-set-attribute! elt a v))]
|
||||
[click
|
||||
(lambda ()
|
||||
(mxprims:element-click elt))]
|
||||
[tag
|
||||
(lambda ()
|
||||
(mxprims:element-tag elt))]
|
||||
[font-family
|
||||
(lambda ()
|
||||
(mxprims:element-font-family elt))]
|
||||
[set-font-family!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-font-family! elt s))]
|
||||
[font-style
|
||||
(lambda ()
|
||||
(mxprims:element-font-style elt))]
|
||||
[set-font-style!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-font-style! elt s))]
|
||||
[font-variant
|
||||
(lambda ()
|
||||
(mxprims:element-font-variant elt))]
|
||||
[set-font-variant!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-font-variant! elt s))]
|
||||
[font-weight
|
||||
(lambda ()
|
||||
(mxprims:element-font-weight elt))]
|
||||
[set-font-weight!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-font-weight! elt s))]
|
||||
[font
|
||||
(lambda ()
|
||||
(mxprims:element-font elt))]
|
||||
[set-font!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-font! elt s))]
|
||||
[background
|
||||
(lambda ()
|
||||
(mxprims:element-background elt))]
|
||||
[set-background!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-background! elt s))]
|
||||
[background-image
|
||||
(lambda ()
|
||||
(mxprims:element-background-image elt))]
|
||||
[set-background-image!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-background-image! elt s))]
|
||||
[background-repeat
|
||||
(lambda ()
|
||||
(mxprims:element-background-repeat elt))]
|
||||
[set-background-repeat!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-background-repeat! elt s))]
|
||||
[background-position
|
||||
(lambda ()
|
||||
(mxprims:element-background-position elt))]
|
||||
[set-background-position!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-background-position! elt s))]
|
||||
[text-decoration
|
||||
(lambda ()
|
||||
(mxprims:element-text-decoration elt))]
|
||||
[set-text-decoration!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-text-decoration! elt s))]
|
||||
[text-transform
|
||||
(lambda ()
|
||||
(mxprims:element-text-transform elt))]
|
||||
[set-text-transform!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-text-transform! elt s))]
|
||||
[text-align
|
||||
(lambda ()
|
||||
(mxprims:element-text-align elt))]
|
||||
[set-text-align!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-text-align! elt s))]
|
||||
[margin
|
||||
(lambda ()
|
||||
(mxprims:element-margin elt))]
|
||||
[set-margin!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-margin! elt s))]
|
||||
[padding
|
||||
(lambda ()
|
||||
(mxprims:element-padding elt))]
|
||||
[set-padding!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-padding! elt s))]
|
||||
[border
|
||||
(lambda ()
|
||||
(mxprims:element-border elt))]
|
||||
[set-border!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-border! elt s))]
|
||||
[border-top
|
||||
(lambda ()
|
||||
(mxprims:element-border-top elt))]
|
||||
[set-border-top!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-border-top! elt s))]
|
||||
[border-bottom
|
||||
(lambda ()
|
||||
(mxprims:element-border-bottom elt))]
|
||||
[set-border-bottom!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-border-bottom! elt s))]
|
||||
[border-left
|
||||
(lambda ()
|
||||
(mxprims:element-border-left elt))]
|
||||
[set-border-left!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-border-left! elt s))]
|
||||
[border-right
|
||||
(lambda ()
|
||||
(mxprims:element-border-right elt))]
|
||||
[set-border-right!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-border-right! elt s))]
|
||||
[border-color
|
||||
(lambda ()
|
||||
(mxprims:element-border-color elt))]
|
||||
[set-border-color!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-border-color! elt s))]
|
||||
[border-width
|
||||
(lambda ()
|
||||
(mxprims:element-border-width elt))]
|
||||
[set-border-width!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-border-width! elt s))]
|
||||
[border-style
|
||||
(lambda ()
|
||||
(mxprims:element-border-style elt))]
|
||||
[set-border-style!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-border-style! elt s))]
|
||||
[border-top-style
|
||||
(lambda ()
|
||||
(mxprims:element-border-top-style elt))]
|
||||
[set-border-top-style!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-border-top-style! elt s))]
|
||||
[border-bottom-style
|
||||
(lambda ()
|
||||
(mxprims:element-border-bottom-style elt))]
|
||||
[set-border-bottom-style!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-border-bottom-style! elt s))]
|
||||
[border-left-style
|
||||
(lambda ()
|
||||
(mxprims:element-border-left-style elt))]
|
||||
[set-border-left-style!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-border-left-style! elt s))]
|
||||
[border-right-style
|
||||
(lambda ()
|
||||
(mxprims:element-border-right-style elt))]
|
||||
[set-border-right-style!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-border-right-style! elt s))]
|
||||
[style-float
|
||||
(lambda ()
|
||||
(mxprims:element-style-float elt))]
|
||||
[set-style-float!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-style-float! elt s))]
|
||||
[clear
|
||||
(lambda ()
|
||||
(mxprims:element-clear elt))]
|
||||
[set-clear!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-clear! elt s))]
|
||||
[display
|
||||
(lambda ()
|
||||
(mxprims:element-display elt))]
|
||||
[set-display!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-display! elt s))]
|
||||
[visibility
|
||||
(lambda ()
|
||||
(mxprims:element-visibility elt))]
|
||||
[set-visibility!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-visibility! elt s))]
|
||||
[list-style-type
|
||||
(lambda ()
|
||||
(mxprims:element-list-style-type elt))]
|
||||
[set-list-style-type!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-list-style-type! elt s))]
|
||||
[list-style-position
|
||||
(lambda ()
|
||||
(mxprims:element-list-style-position elt))]
|
||||
[set-list-style-position!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-list-style-position! elt s))]
|
||||
[list-style-image
|
||||
(lambda ()
|
||||
(mxprims:element-list-style-image elt))]
|
||||
[set-list-style-image!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-list-style-image! elt s))]
|
||||
[list-style
|
||||
(lambda ()
|
||||
(mxprims:element-list-style elt))]
|
||||
[set-list-style!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-list-style! elt s))]
|
||||
[whitespace
|
||||
(lambda ()
|
||||
(mxprims:element-whitespace elt))]
|
||||
[set-whitespace!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-whitespace! elt s))]
|
||||
[position
|
||||
(lambda ()
|
||||
(mxprims:element-position elt))]
|
||||
[overflow
|
||||
(lambda ()
|
||||
(mxprims:element-overflow elt))]
|
||||
[set-overflow!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-overflow! elt s))]
|
||||
[pagebreak-before
|
||||
(lambda ()
|
||||
(mxprims:element-pagebreak-before elt))]
|
||||
[set-pagebreak-before!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-pagebreak-before! elt s))]
|
||||
[pagebreak-after
|
||||
(lambda ()
|
||||
(mxprims:element-pagebreak-after elt))]
|
||||
[set-pagebreak-after!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-pagebreak-after! elt s))]
|
||||
[css-text
|
||||
(lambda ()
|
||||
(mxprims:element-css-text elt))]
|
||||
[set-css-text!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-css-text! elt s))]
|
||||
[cursor
|
||||
(lambda ()
|
||||
(mxprims:element-cursor elt))]
|
||||
[set-cursor!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-cursor! elt s))]
|
||||
[clip
|
||||
(lambda ()
|
||||
(mxprims:element-clip elt))]
|
||||
[set-clip!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-clip! elt s))]
|
||||
[filter
|
||||
(lambda ()
|
||||
(mxprims:element-filter elt))]
|
||||
[set-filter!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-filter! elt s))]
|
||||
[style-string
|
||||
(lambda ()
|
||||
(mxprims:element-style-string elt))]
|
||||
[text-decoration-none
|
||||
(lambda ()
|
||||
(mxprims:element-text-decoration-none elt))]
|
||||
[set-text-decoration-none!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-text-decoration-none! elt s))]
|
||||
[text-decoration-underline
|
||||
(lambda ()
|
||||
(mxprims:element-text-decoration-underline elt))]
|
||||
[set-text-decoration-underline!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-text-decoration-underline! elt s))]
|
||||
[text-decoration-overline
|
||||
(lambda ()
|
||||
(mxprims:element-text-decoration-overline elt))]
|
||||
[set-text-decoration-overline!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-text-decoration-overline! elt s))]
|
||||
[text-decoration-linethrough
|
||||
(lambda ()
|
||||
(mxprims:element-text-decoration-linethrough elt))]
|
||||
[set-text-decoration-linethrough!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-text-decoration-linethrough! elt s))]
|
||||
[text-decoration-blink
|
||||
(lambda ()
|
||||
(mxprims:element-text-decoration-blink elt))]
|
||||
[set-text-decoration-blink!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-text-decoration-blink! elt s))]
|
||||
[pixel-top
|
||||
(lambda ()
|
||||
(mxprims:element-pixel-top elt))]
|
||||
[set-pixel-top!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-pixel-top! elt s))]
|
||||
[pixel-left
|
||||
(lambda ()
|
||||
(mxprims:element-pixel-left elt))]
|
||||
[set-pixel-left!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-pixel-left! elt s))]
|
||||
[pixel-width
|
||||
(lambda ()
|
||||
(mxprims:element-pixel-width elt))]
|
||||
[set-pixel-width!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-pixel-width! elt s))]
|
||||
[pixel-height
|
||||
(lambda ()
|
||||
(mxprims:element-pixel-height elt))]
|
||||
[set-pixel-height!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-pixel-height! elt s))]
|
||||
[pos-top
|
||||
(lambda ()
|
||||
(mxprims:element-pos-top elt))]
|
||||
[set-pos-top!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-pos-top! elt s))]
|
||||
[pos-left
|
||||
(lambda ()
|
||||
(mxprims:element-pos-left elt))]
|
||||
[set-pos-left!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-pos-left! elt s))]
|
||||
[pos-width
|
||||
(lambda ()
|
||||
(mxprims:element-pos-width elt))]
|
||||
[set-pos-width!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-pos-width! elt s))]
|
||||
[pos-height
|
||||
(lambda ()
|
||||
(mxprims:element-pos-height elt))]
|
||||
[set-pos-height!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-pos-height! elt s))]
|
||||
[font-size
|
||||
(lambda ()
|
||||
(mxprims:element-font-size elt))]
|
||||
[set-font-size!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-font-size! elt s))]
|
||||
[color
|
||||
(lambda ()
|
||||
(mxprims:element-color elt))]
|
||||
[set-color!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-color! elt s))]
|
||||
[background-color
|
||||
(lambda ()
|
||||
(mxprims:element-background-color elt))]
|
||||
[set-background-color!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-background-color! elt s))]
|
||||
[background-position-x
|
||||
(lambda ()
|
||||
(mxprims:element-background-position-x elt))]
|
||||
[set-background-position-x!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-background-position-x! elt s))]
|
||||
[background-position-y
|
||||
(lambda ()
|
||||
(mxprims:element-background-position-y elt))]
|
||||
[set-background-position-y!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-background-position-y! elt s))]
|
||||
[word-spacing
|
||||
(lambda ()
|
||||
(mxprims:element-word-spacing elt))]
|
||||
[set-word-spacing!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-word-spacing! elt s))]
|
||||
[letter-spacing
|
||||
(lambda ()
|
||||
(mxprims:element-letter-spacing elt))]
|
||||
[set-letter-spacing!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-letter-spacing! elt s))]
|
||||
[vertical-align
|
||||
(lambda ()
|
||||
(mxprims:element-vertical-align elt))]
|
||||
[set-vertical-align!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-vertical-align! elt s))]
|
||||
[text-indent
|
||||
(lambda ()
|
||||
(mxprims:element-text-indent elt))]
|
||||
[set-text-indent!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-text-indent! elt s))]
|
||||
[line-height
|
||||
(lambda ()
|
||||
(mxprims:element-line-height elt))]
|
||||
[set-line-height!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-line-height! elt s))]
|
||||
[margin-top
|
||||
(lambda ()
|
||||
(mxprims:element-margin-top elt))]
|
||||
[set-margin-top!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-margin-top! elt s))]
|
||||
[margin-bottom
|
||||
(lambda ()
|
||||
(mxprims:element-margin-bottom elt))]
|
||||
[set-margin-bottom!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-margin-bottom! elt s))]
|
||||
[margin-left
|
||||
(lambda ()
|
||||
(mxprims:element-margin-left elt))]
|
||||
[set-margin-left!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-margin-left! elt s))]
|
||||
[margin-right
|
||||
(lambda ()
|
||||
(mxprims:element-margin-right elt))]
|
||||
[set-margin-right!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-margin-right! elt s))]
|
||||
[padding-top
|
||||
(lambda ()
|
||||
(mxprims:element-padding-top elt))]
|
||||
[set-padding-top!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-padding-top! elt s))]
|
||||
[padding-bottom
|
||||
(lambda ()
|
||||
(mxprims:element-padding-bottom elt))]
|
||||
[set-padding-bottom!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-padding-bottom! elt s))]
|
||||
[padding-left
|
||||
(lambda ()
|
||||
(mxprims:element-padding-left elt))]
|
||||
[set-padding-left!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-padding-left! elt s))]
|
||||
[padding-right
|
||||
(lambda ()
|
||||
(mxprims:element-padding-right elt))]
|
||||
[set-padding-right!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-padding-right! elt s))]
|
||||
[border-top-color
|
||||
(lambda ()
|
||||
(mxprims:element-border-top-color elt))]
|
||||
[set-border-top-color!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-border-top-color! elt s))]
|
||||
[border-bottom-color
|
||||
(lambda ()
|
||||
(mxprims:element-border-bottom-color elt))]
|
||||
[set-border-bottom-color!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-border-bottom-color! elt s))]
|
||||
[border-left-color
|
||||
(lambda ()
|
||||
(mxprims:element-border-left-color elt))]
|
||||
[set-border-left-color!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-border-left-color! elt s))]
|
||||
[border-right-color
|
||||
(lambda ()
|
||||
(mxprims:element-border-right-color elt))]
|
||||
[set-border-right-color!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-border-right-color! elt s))]
|
||||
[border-top-width
|
||||
(lambda ()
|
||||
(mxprims:element-border-top-width elt))]
|
||||
[set-border-top-width!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-border-top-width! elt s))]
|
||||
[border-bottom-width
|
||||
(lambda ()
|
||||
(mxprims:element-border-bottom-width elt))]
|
||||
[set-border-bottom-width!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-border-bottom-width! elt s))]
|
||||
[border-left-width
|
||||
(lambda ()
|
||||
(mxprims:element-border-left-width elt))]
|
||||
[set-border-left-width!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-border-left-width! elt s))]
|
||||
[border-right-width
|
||||
(lambda ()
|
||||
(mxprims:element-border-right-width elt))]
|
||||
[set-border-right-width!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-border-right-width! elt s))]
|
||||
[width
|
||||
(lambda ()
|
||||
(mxprims:element-width elt))]
|
||||
[set-width!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-width! elt s))]
|
||||
[height
|
||||
(lambda ()
|
||||
(mxprims:element-height elt))]
|
||||
[set-height!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-height! elt s))]
|
||||
[top
|
||||
(lambda ()
|
||||
(mxprims:element-top elt))]
|
||||
[set-top!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-top! elt s))]
|
||||
[left
|
||||
(lambda ()
|
||||
(mxprims:element-left elt))]
|
||||
[set-left!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-left! elt s))]
|
||||
[z-index
|
||||
(lambda ()
|
||||
(mxprims:element-z-index elt))]
|
||||
[set-z-index!
|
||||
(lambda (s)
|
||||
(mxprims:element-set-z-index! elt s))])
|
||||
|
||||
(sequence (super-init))))
|
||||
|
||||
(define mx-event%
|
||||
(class object% (dhtml-event)
|
||||
|
||||
(private
|
||||
[event dhtml-event])
|
||||
|
||||
(public
|
||||
|
||||
; predicates
|
||||
|
||||
[keypress? (lambda () (mxprims:event-keypress? event))]
|
||||
[keydown? (lambda () (mxprims:event-keydown? event))]
|
||||
[keyup? (lambda () (mxprims:event-keyup? event))]
|
||||
[mousedown? (lambda () (mxprims:event-mousedown? event))]
|
||||
[mousemove? (lambda () (mxprims:event-mousemove? event))]
|
||||
[mouseover? (lambda () (mxprims:event-mouseover? event))]
|
||||
[mouseout? (lambda () (mxprims:event-mouseout? event))]
|
||||
[mouseup? (lambda () (mxprims:event-mouseup? event))]
|
||||
[click? (lambda () (mxprims:event-click? event))]
|
||||
[dblclick? (lambda () (mxprims:event-dblclick? event))]
|
||||
[error? (lambda () (mxprims:event-error? event))]
|
||||
|
||||
; attributes
|
||||
|
||||
[tag (lambda () (mxprims:event-tag event))]
|
||||
[id (lambda () (mxprims:event-id event))]
|
||||
[from-tag (lambda () (mxprims:event-from-tag event))]
|
||||
[from-id (lambda () (mxprims:event-id event))]
|
||||
[to-tag (lambda () (mxprims:event-to-tag event))]
|
||||
[to-id (lambda () (mxprims:event-to-id event))]
|
||||
[keycode (lambda () (mxprims:event-keycode event))]
|
||||
[shiftkey (lambda () (mxprims:event-shiftkey event))]
|
||||
[ctrlkey (lambda () (mxprims:event-ctrlkey event))]
|
||||
[altkey (lambda () (mxprims:event-altkey event))]
|
||||
[x (lambda () (mxprims:event-x event))]
|
||||
[y (lambda () (mxprims:event-y event))])
|
||||
|
||||
(sequence (super-init))))
|
||||
|
||||
|
||||
(define mx-document%
|
||||
(class object%
|
||||
|
||||
((label "MysterX")
|
||||
(width 'default)
|
||||
(height 'default)
|
||||
(x 'default)
|
||||
(y 'default)
|
||||
(style-options null))
|
||||
|
||||
(private
|
||||
[doc (mxprims:make-document label width height x y style-options)]
|
||||
[thread-sem (make-semaphore 1)] ; protects *handler-threads*
|
||||
[thread-wait (lambda () (semaphore-wait thread-sem))]
|
||||
[thread-post (lambda () (semaphore-post thread-sem))]
|
||||
[handler-sem (make-semaphore 1)] ; protects *handler-table* and its contained hash tables
|
||||
[handler-wait (lambda () (semaphore-wait handler-sem))]
|
||||
[handler-post (lambda () (semaphore-post handler-sem))]
|
||||
[handler-table (make-hash-table)]
|
||||
[handler-thread #f]
|
||||
[block-until-event
|
||||
(lambda () (mxprims:block-until-event doc))]
|
||||
[make-event-key
|
||||
(lambda (tag id) ; string x string -> symbol
|
||||
(let ([new-tag (string-copy tag)]
|
||||
[new-id (string-copy id)])
|
||||
(string-uppercase! new-tag)
|
||||
(string-uppercase! new-id)
|
||||
(string->symbol
|
||||
(string-append new-tag "@" new-id))))])
|
||||
|
||||
(public
|
||||
[show
|
||||
(lambda (b)
|
||||
(mxprims:document-show doc b))]
|
||||
[find-element
|
||||
(lambda (tag id)
|
||||
(make-object mx-element% doc (mxprims:document-find-element doc tag id)))]
|
||||
[objects
|
||||
(lambda ()
|
||||
(mxprims:document-objects doc))]
|
||||
[insert-html
|
||||
(lambda (html-string)
|
||||
(dynamic-wind
|
||||
html-wait
|
||||
(lambda () (mxprims:document-insert-html doc html-string))
|
||||
html-post))]
|
||||
[append-html
|
||||
(lambda (html-string)
|
||||
(dynamic-wind
|
||||
html-wait
|
||||
(lambda () (mxprims:document-append-html doc html-string))
|
||||
html-post))]
|
||||
[replace-html
|
||||
(lambda (html-string)
|
||||
(dynamic-wind
|
||||
html-wait
|
||||
(lambda () (mxprims:document-replace-html doc html-string))
|
||||
html-post))]
|
||||
[register-event-handler
|
||||
(lambda (elt fn)
|
||||
(dynamic-wind
|
||||
handler-wait
|
||||
(lambda ()
|
||||
(let* ([tag (send elt tag)]
|
||||
[id (send elt attribute "id")])
|
||||
(let ([key (make-event-key tag id)])
|
||||
(hash-table-remove! handler-table key)
|
||||
(hash-table-put! handler-table key fn))))
|
||||
handler-post))]
|
||||
[unregister-event-handler
|
||||
(lambda (elt)
|
||||
(dynamic-wind
|
||||
handler-wait
|
||||
(lambda ()
|
||||
(let* ([tag (send elt tag)]
|
||||
[id (send elt attribute "id")])
|
||||
(let ([key (make-event-key tag id)])
|
||||
(hash-table-remove! handler-table key))))
|
||||
handler-post))]
|
||||
[insert-object
|
||||
(opt-lambda (object width height [size 'pixels])
|
||||
(dynamic-wind
|
||||
html-wait
|
||||
(lambda ()
|
||||
(mxprims:document-insert-html
|
||||
doc
|
||||
(coclass->html object width height size))
|
||||
(car (mxprims:document-objects doc)))
|
||||
html-post))]
|
||||
[append-object
|
||||
(opt-lambda (object width height [size 'pixels])
|
||||
(dynamic-wind
|
||||
html-wait
|
||||
(lambda ()
|
||||
(mxprims:document-append-html
|
||||
doc
|
||||
(coclass->html object width height size))
|
||||
(car (last-pair (mxprims:document-objects doc))))
|
||||
html-post))]
|
||||
[handle-events
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
thread-wait
|
||||
(lambda () ; no-op if existing handler-thread
|
||||
(unless handler-thread
|
||||
(dynamic-wind
|
||||
handler-wait
|
||||
(lambda ()
|
||||
(let* ([handler-thunk
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(block-until-event)
|
||||
(let* ([prim-event
|
||||
(with-handlers
|
||||
([void
|
||||
(lambda (e)
|
||||
(printf "~a~n" (exn-message e))
|
||||
(loop))])
|
||||
(mxprims:get-event doc))]
|
||||
[event (make-object mx-event% prim-event)]
|
||||
[tag (send event tag)]
|
||||
[id (send event id)]
|
||||
[key (make-event-key tag id)]
|
||||
[handler (hash-table-get handler-table key void)])
|
||||
(unless (void? handler)
|
||||
(handler event))
|
||||
(loop))))])
|
||||
(set! handler-thread (thread handler-thunk))))
|
||||
handler-post)))
|
||||
thread-post))]
|
||||
[stop-handling-events
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
thread-wait
|
||||
(lambda ()
|
||||
(when handler-thread
|
||||
(kill-thread handler-thread))
|
||||
(set! handler-thread #f))
|
||||
thread-post))])
|
||||
|
||||
(sequence
|
||||
(super-init))))
|
||||
|
||||
(thread
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(mxprims:process-win-events)
|
||||
(sleep)
|
||||
(loop))))
|
||||
|
||||
(let ([old-exit-handler (exit-handler)])
|
||||
(exit-handler
|
||||
(lambda (arg)
|
||||
(for-each
|
||||
(lambda (obj)
|
||||
(let ([val (cdr obj)])
|
||||
(cond
|
||||
[(com-object? val)
|
||||
(mxprims:com-release-object (cdr obj))]
|
||||
|
||||
; rely on GC to release interfaces in documents, elements
|
||||
; not entirely reliable, since collector is conservative
|
||||
|
||||
[(or (is-a? val mx-document%)
|
||||
(is-a? val mx-element%))
|
||||
(undefine (car obj))])))
|
||||
(make-global-value-list))
|
||||
(collect-garbage)
|
||||
(mxprims:release-type-table)
|
||||
(mxprims:com-terminate)
|
||||
(old-exit-handler arg)))))
|
||||
|
||||
|
||||
|
||||
21
collects/mysterx/mysterxu.ss
Normal file
21
collects/mysterx/mysterxu.ss
Normal file
|
|
@ -0,0 +1,21 @@
|
|||
;;; mysterxu.ss
|
||||
|
||||
(require-library "cores.ss")
|
||||
(require-library "macro.ss")
|
||||
|
||||
(require-library "sigs.ss" "mysterx")
|
||||
|
||||
(require-library "xmls.ss" "xml")
|
||||
|
||||
(define mysterx@
|
||||
(compound-unit/sig
|
||||
(import)
|
||||
(link [core : mzlib:core^ ((require-library "corer.ss"))]
|
||||
[mxprims : mysterx:prims^ ((require-library "prims.ss" "mysterx"))]
|
||||
[xml : xml^ ((require-library "xmlr.ss" "xml") (core function))]
|
||||
[mysterx : mysterx:mysterx^
|
||||
((require-library "mysterxe.ss" "mysterx")
|
||||
(core function) (core string)
|
||||
mxprims xml)])
|
||||
(export
|
||||
(open mysterx))))
|
||||
7
collects/mysterx/prims.ss
Normal file
7
collects/mysterx/prims.ss
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
;; prims.ss
|
||||
|
||||
(unit->unit/sig
|
||||
(load-extension
|
||||
(build-path (collection-path "mysterx") "dlls" "mxmain.dll"))
|
||||
()
|
||||
mysterx:prims^)
|
||||
276
collects/mysterx/sigs.ss
Normal file
276
collects/mysterx/sigs.ss
Normal file
|
|
@ -0,0 +1,276 @@
|
|||
;; sigs.ss for mysterx collection
|
||||
|
||||
(define-signature mysterx:mysterx^
|
||||
(mx-document%
|
||||
xexp->string
|
||||
com-invoke
|
||||
com-set-property!
|
||||
com-get-property
|
||||
com-methods
|
||||
com-get-properties
|
||||
com-set-properties
|
||||
com-events
|
||||
com-method-type
|
||||
com-get-property-type
|
||||
com-set-property-type
|
||||
com-event-type
|
||||
com-object-type
|
||||
com-is-a?
|
||||
com-help
|
||||
com-register-event-handler
|
||||
com-unregister-event-handler
|
||||
com-all-coclasses
|
||||
com-all-controls
|
||||
coclass->html
|
||||
cocreate-instance
|
||||
com-object-eq?
|
||||
com-object?
|
||||
com-omit))
|
||||
|
||||
(define-signature mysterx:prims^
|
||||
(com-invoke
|
||||
com-set-property!
|
||||
com-get-property
|
||||
com-methods
|
||||
com-get-properties
|
||||
com-set-properties
|
||||
com-events
|
||||
com-method-type
|
||||
com-get-property-type
|
||||
com-set-property-type
|
||||
com-event-type
|
||||
com-object-type
|
||||
com-is-a?
|
||||
com-help
|
||||
com-register-event-handler
|
||||
com-unregister-event-handler
|
||||
com-all-coclasses
|
||||
com-all-controls
|
||||
coclass->html
|
||||
cocreate-instance
|
||||
com-object-eq?
|
||||
com-object?
|
||||
com-register-object
|
||||
com-release-object
|
||||
make-document
|
||||
document?
|
||||
document-insert-html
|
||||
document-append-html
|
||||
document-replace-html
|
||||
document-find-element
|
||||
document-objects
|
||||
document-show
|
||||
element-insert-html
|
||||
element-append-html
|
||||
element-insert-text
|
||||
element-append-text
|
||||
element-replace-html
|
||||
element-attribute
|
||||
element-set-attribute!
|
||||
element-click
|
||||
element-tag
|
||||
element-font-family
|
||||
element-set-font-family!
|
||||
element-font-style
|
||||
element-set-font-style!
|
||||
element-font-variant
|
||||
element-set-font-variant!
|
||||
element-font-weight
|
||||
element-set-font-weight!
|
||||
element-font
|
||||
element-set-font!
|
||||
element-background
|
||||
element-set-background!
|
||||
element-background-image
|
||||
element-set-background-image!
|
||||
element-background-repeat
|
||||
element-set-background-repeat!
|
||||
element-background-position
|
||||
element-set-background-position!
|
||||
element-text-decoration
|
||||
element-set-text-decoration!
|
||||
element-text-transform
|
||||
element-set-text-transform!
|
||||
element-text-align
|
||||
element-set-text-align!
|
||||
element-margin
|
||||
element-set-margin!
|
||||
element-padding
|
||||
element-set-padding!
|
||||
element-border
|
||||
element-set-border!
|
||||
element-border-top
|
||||
element-set-border-top!
|
||||
element-border-bottom
|
||||
element-set-border-bottom!
|
||||
element-border-left
|
||||
element-set-border-left!
|
||||
element-border-right
|
||||
element-set-border-right!
|
||||
element-border-color
|
||||
element-set-border-color!
|
||||
element-border-width
|
||||
element-set-border-width!
|
||||
element-border-style
|
||||
element-set-border-style!
|
||||
element-border-top-style
|
||||
element-set-border-top-style!
|
||||
element-border-bottom-style
|
||||
element-set-border-bottom-style!
|
||||
element-border-left-style
|
||||
element-set-border-left-style!
|
||||
element-border-right-style
|
||||
element-set-border-right-style!
|
||||
element-style-float
|
||||
element-set-style-float!
|
||||
element-clear
|
||||
element-set-clear!
|
||||
element-display
|
||||
element-set-display!
|
||||
element-visibility
|
||||
element-set-visibility!
|
||||
element-list-style-type
|
||||
element-set-list-style-type!
|
||||
element-list-style-position
|
||||
element-set-list-style-position!
|
||||
element-list-style-image
|
||||
element-set-list-style-image!
|
||||
element-list-style
|
||||
element-set-list-style!
|
||||
element-whitespace
|
||||
element-set-whitespace!
|
||||
element-position
|
||||
element-overflow
|
||||
element-set-overflow!
|
||||
element-pagebreak-before
|
||||
element-set-pagebreak-before!
|
||||
element-pagebreak-after
|
||||
element-set-pagebreak-after!
|
||||
element-css-text
|
||||
element-set-css-text!
|
||||
element-cursor
|
||||
element-set-cursor!
|
||||
element-clip
|
||||
element-set-clip!
|
||||
element-filter
|
||||
element-set-filter!
|
||||
element-style-string
|
||||
element-text-decoration-none
|
||||
element-set-text-decoration-none!
|
||||
element-text-decoration-underline
|
||||
element-set-text-decoration-underline!
|
||||
element-text-decoration-overline
|
||||
element-set-text-decoration-overline!
|
||||
element-text-decoration-linethrough
|
||||
element-set-text-decoration-linethrough!
|
||||
element-text-decoration-blink
|
||||
element-set-text-decoration-blink!
|
||||
element-pixel-top
|
||||
element-set-pixel-top!
|
||||
element-pixel-left
|
||||
element-set-pixel-left!
|
||||
element-pixel-width
|
||||
element-set-pixel-width!
|
||||
element-pixel-height
|
||||
element-set-pixel-height!
|
||||
element-pos-top
|
||||
element-set-pos-top!
|
||||
element-pos-left
|
||||
element-set-pos-left!
|
||||
element-pos-width
|
||||
element-set-pos-width!
|
||||
element-pos-height
|
||||
element-set-pos-height!
|
||||
element-font-size
|
||||
element-set-font-size!
|
||||
element-color
|
||||
element-set-color!
|
||||
element-background-color
|
||||
element-set-background-color!
|
||||
element-background-position-x
|
||||
element-set-background-position-x!
|
||||
element-background-position-y
|
||||
element-set-background-position-y!
|
||||
element-word-spacing
|
||||
element-set-word-spacing!
|
||||
element-letter-spacing
|
||||
element-set-letter-spacing!
|
||||
element-vertical-align
|
||||
element-set-vertical-align!
|
||||
element-text-indent
|
||||
element-set-text-indent!
|
||||
element-line-height
|
||||
element-set-line-height!
|
||||
element-margin-top
|
||||
element-set-margin-top!
|
||||
element-margin-bottom
|
||||
element-set-margin-bottom!
|
||||
element-margin-left
|
||||
element-set-margin-left!
|
||||
element-margin-right
|
||||
element-set-margin-right!
|
||||
element-padding-top
|
||||
element-set-padding-top!
|
||||
element-padding-bottom
|
||||
element-set-padding-bottom!
|
||||
element-padding-left
|
||||
element-set-padding-left!
|
||||
element-padding-right
|
||||
element-set-padding-right!
|
||||
element-border-top-color
|
||||
element-set-border-top-color!
|
||||
element-border-bottom-color
|
||||
element-set-border-bottom-color!
|
||||
element-border-left-color
|
||||
element-set-border-left-color!
|
||||
element-border-right-color
|
||||
element-set-border-right-color!
|
||||
element-border-top-width
|
||||
element-set-border-top-width!
|
||||
element-border-bottom-width
|
||||
element-set-border-bottom-width!
|
||||
element-border-left-width
|
||||
element-set-border-left-width!
|
||||
element-border-right-width
|
||||
element-set-border-right-width!
|
||||
element-width
|
||||
element-set-width!
|
||||
element-height
|
||||
element-set-height!
|
||||
element-top
|
||||
element-set-top!
|
||||
element-left
|
||||
element-set-left!
|
||||
element-z-index
|
||||
element-set-z-index!
|
||||
event?
|
||||
get-event
|
||||
event-tag
|
||||
event-id
|
||||
event-from-tag
|
||||
event-from-id
|
||||
event-to-tag
|
||||
event-to-id
|
||||
event-keycode
|
||||
event-shiftkey
|
||||
event-ctrlkey
|
||||
event-altkey
|
||||
event-x
|
||||
event-y
|
||||
event-keypress?
|
||||
event-keydown?
|
||||
event-keyup?
|
||||
event-mousedown?
|
||||
event-mousemove?
|
||||
event-mouseover?
|
||||
event-mouseout?
|
||||
event-mouseup?
|
||||
event-click?
|
||||
event-dblclick?
|
||||
event-error?
|
||||
block-until-event
|
||||
process-win-events
|
||||
com-omit
|
||||
com-terminate
|
||||
release-type-table))
|
||||
|
||||
13
collects/mzlib/awk.ss
Normal file
13
collects/mzlib/awk.ss
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(begin-elaboration-time
|
||||
(define-values/invoke-unit (awk)
|
||||
(require-relative-library "awkr.ss")))
|
||||
|
||||
(define-macro awk awk)
|
||||
|
||||
(define-values/invoke-unit (match:start match:end match:substring regexp-exec)
|
||||
(require-relative-library "awkr.ss"))
|
||||
|
||||
177
collects/mzlib/awkr.ss
Normal file
177
collects/mzlib/awkr.ss
Normal file
|
|
@ -0,0 +1,177 @@
|
|||
|
||||
(unit
|
||||
(import)
|
||||
(export awk match:start match:end match:substring regexp-exec)
|
||||
|
||||
(define awk
|
||||
(lambda (get-next-record . rest)
|
||||
(let*-values ([(user-fields rest) (values (car rest) (cdr rest))]
|
||||
[(counter rest) (if (and (pair? rest) (symbol? (car rest)))
|
||||
(values (car rest) (cdr rest))
|
||||
(values (gensym) rest))]
|
||||
[(user-state-var-decls rest) (values (car rest) (cdr rest))]
|
||||
[(continue rest) (if (and (pair? rest) (symbol? (car rest)))
|
||||
(values (car rest) (cdr rest))
|
||||
(values (gensym) rest))]
|
||||
[(user-state-vars) (map car user-state-var-decls)]
|
||||
[(local-user-state-vars) (map gensym user-state-vars)]
|
||||
[(first) (car user-fields)]
|
||||
[(clauses) rest]
|
||||
[(loop) (gensym)]
|
||||
[(remainder) (gensym)]
|
||||
[(extras) (gensym)]
|
||||
[(arg) (gensym)]
|
||||
[(else-ready?) (gensym)]
|
||||
[(orig-on?) (gensym)]
|
||||
[(post-on-on?) (gensym)]
|
||||
[(escape) (gensym)]
|
||||
[(initvars) null])
|
||||
(letrec ([get-after-clauses
|
||||
(lambda ()
|
||||
(let loop ([l clauses][afters null])
|
||||
(cond
|
||||
[(null? l) (if (null? afters)
|
||||
`((values ,@user-state-vars))
|
||||
afters)]
|
||||
[(eq? (caar l) 'after)
|
||||
(loop (cdr l) (append afters (cdar l)))]
|
||||
[else
|
||||
(loop (cdr l) afters)])))]
|
||||
[wrap-state
|
||||
(lambda (e)
|
||||
(if (eq? (car e) '=>)
|
||||
`(=>
|
||||
(lambda (,arg)
|
||||
,@(wrap-state `((,(cadr e) ,arg)))))
|
||||
`((call-with-values
|
||||
(lambda () ,@e)
|
||||
(lambda ,(append local-user-state-vars extras)
|
||||
(set! ,else-ready? #f)
|
||||
(set!-values ,user-state-vars
|
||||
(values ,@local-user-state-vars)))))))]
|
||||
[make-range
|
||||
(lambda (include-on? include-off? body rest)
|
||||
(let* ([on? (gensym)])
|
||||
(set! initvars (cons `(,on? #f) initvars))
|
||||
(cons
|
||||
`(let ([,orig-on? ,on?])
|
||||
(unless ,on? (set! ,on? ,(make-test (car body))))
|
||||
(let ([,post-on-on? ,on?])
|
||||
(when ,on? (set! ,on? (not ,(make-test (cadr body)))))
|
||||
(when ,(if include-on?
|
||||
(if include-off?
|
||||
post-on-on?
|
||||
on?)
|
||||
(if include-off?
|
||||
orig-on?
|
||||
`(and ,orig-on? ,on?)))
|
||||
,@(wrap-state (cddr body)))))
|
||||
rest)))]
|
||||
[make-test
|
||||
(lambda (test)
|
||||
(cond
|
||||
[(string? test)
|
||||
(let ([g (gensym)])
|
||||
(set! initvars (cons `(,g (regexp ,test)) initvars))
|
||||
`(regexp-exec ,g ,first))]
|
||||
[(number? test)
|
||||
`(= ,test ,counter)]
|
||||
[else test]))]
|
||||
[get-testing-clauses
|
||||
(lambda ()
|
||||
(let loop ([l clauses])
|
||||
(if (null? l)
|
||||
null
|
||||
(let* ([clause (car l)]
|
||||
[test (car clause)]
|
||||
[body (cdr clause)]
|
||||
[rest (loop (cdr l))])
|
||||
(cond
|
||||
[(or (string? test) (number? test))
|
||||
(cons
|
||||
`(cond [,(make-test test)
|
||||
,@(wrap-state body)]
|
||||
[else (void)])
|
||||
rest)]
|
||||
[(eq? test 'else)
|
||||
(cons
|
||||
`(when ,else-ready?
|
||||
,@(wrap-state body))
|
||||
(cons
|
||||
`(set! ,else-ready? #t)
|
||||
rest))]
|
||||
[(eq? test 'range)
|
||||
(make-range #f #f body rest)]
|
||||
[(eq? test ':range)
|
||||
(make-range #t #f body rest)]
|
||||
[(eq? test 'range:)
|
||||
(make-range #f #t body rest)]
|
||||
[(eq? test ':range:)
|
||||
(make-range #t #t body rest)]
|
||||
[(eq? test 'after)
|
||||
rest]
|
||||
[(eq? test '/)
|
||||
(let ([g (gensym)]
|
||||
[re (car body)]
|
||||
[vars (append (map (lambda (s)
|
||||
(or s (gensym)))
|
||||
(caddr body))
|
||||
(gensym))]
|
||||
[body (cdddr body)])
|
||||
(set! initvars (cons `(,g (regexp ,re)) initvars))
|
||||
(cons
|
||||
`(cond
|
||||
[(regexp-match ,re ,first)
|
||||
=> (lambda (,arg)
|
||||
(apply
|
||||
(lambda ,vars ,@(wrap-state body))
|
||||
,arg))]
|
||||
[else (void)])
|
||||
rest))]
|
||||
[else
|
||||
(cons
|
||||
`(cond (,test ,@(wrap-state body)) (else (void)))
|
||||
rest)])))))])
|
||||
(let ([testing-clauses (get-testing-clauses)])
|
||||
`(let (,@user-state-var-decls ,@initvars)
|
||||
(let ,loop ([,counter 1])
|
||||
(call-with-values
|
||||
(lambda () ,get-next-record)
|
||||
(lambda ,user-fields
|
||||
(if (eof-object? ,first)
|
||||
(begin
|
||||
,@(get-after-clauses))
|
||||
(let ([,else-ready? #t])
|
||||
(let/ec ,escape
|
||||
(let ([,continue
|
||||
(lambda ,(append local-user-state-vars extras)
|
||||
(set!-values ,user-state-vars
|
||||
(values ,@local-user-state-vars))
|
||||
(,escape))])
|
||||
,@testing-clauses))
|
||||
(,loop (add1 ,counter)))))))))))))
|
||||
|
||||
(define-struct match (s a))
|
||||
|
||||
(define match:start
|
||||
(case-lambda
|
||||
[(rec) (match:start rec 0)]
|
||||
[(rec which) (car (list-ref (match-a rec) which))]))
|
||||
|
||||
(define match:end
|
||||
(case-lambda
|
||||
[(rec) (match:end rec 0)]
|
||||
[(rec which) (cdr (list-ref (match-a rec) which))]))
|
||||
|
||||
(define match:substring
|
||||
(case-lambda
|
||||
[(rec) (match:substring rec 0)]
|
||||
[(rec which) (let ([p (list-ref (match-a rec) which)])
|
||||
(substring (match-s rec) (car p) (cdr p)))]))
|
||||
|
||||
(define regexp-exec
|
||||
(lambda (re s)
|
||||
(let ([r (regexp-match-positions re s)])
|
||||
(if r
|
||||
(make-match s r)
|
||||
#f)))))
|
||||
9
collects/mzlib/cmdline.ss
Normal file
9
collects/mzlib/cmdline.ss
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
|
||||
(require-library "cmdlineu.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:command-line^ mzlib:command-line@ #f)
|
||||
|
||||
(require-library "cmdlinem.ss")
|
||||
9
collects/mzlib/cmdlinem.ss
Normal file
9
collects/mzlib/cmdlinem.ss
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(begin-elaboration-time
|
||||
(define-values/invoke-unit (command-line)
|
||||
(require-library "cmdlinemr.ss")))
|
||||
|
||||
(define-macro command-line command-line)
|
||||
107
collects/mzlib/cmdlinemr.ss
Normal file
107
collects/mzlib/cmdlinemr.ss
Normal file
|
|
@ -0,0 +1,107 @@
|
|||
|
||||
(unit
|
||||
(import)
|
||||
(export command-line)
|
||||
|
||||
(define command-line
|
||||
(lambda args
|
||||
(let* ([serror
|
||||
(lambda (msg . detail)
|
||||
(apply
|
||||
raise-syntax-error
|
||||
'command-line
|
||||
msg
|
||||
(cons 'command-line args)
|
||||
detail))]
|
||||
[missing
|
||||
(lambda (what)
|
||||
(serror (format "missing ~a" what)))]
|
||||
[extract (lambda (what args . detail)
|
||||
(if (null? args)
|
||||
(apply serror (format "missing ~a" what) detail)
|
||||
(values (car args) (cdr args))))]
|
||||
[listify (lambda (l)
|
||||
(let loop ([l l])
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[(pair? l) (cons (car l) (loop(cdr l)))]
|
||||
[else (list l)])))]
|
||||
[check-formals
|
||||
(lambda (l)
|
||||
(unless (andmap symbol? (listify l))
|
||||
(serror "bad argument specification" l)))]
|
||||
[formal-names
|
||||
(lambda (l)
|
||||
(let loop ([l l])
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[(pair? l) (cons (symbol->string (car l)) (loop(cdr l)))]
|
||||
[else (list (let ([s (symbol->string l)])
|
||||
(if (char=? #\* (string-ref s (sub1 (string-length s))))
|
||||
(substring s 0 (sub1 (string-length s)))
|
||||
s)))])))])
|
||||
(let*-values ([(name args) (extract "name string" args)]
|
||||
[(_) (unless (string? name)
|
||||
(serror "program name is not a string" name))]
|
||||
[(argv args) (extract "argv vector expression" args)])
|
||||
`(parse-command-line
|
||||
,name ,argv
|
||||
,@(let loop ([args args][clauses null])
|
||||
(if (null? args)
|
||||
`((list ,@clauses)
|
||||
(lambda (accum) (void))
|
||||
null)
|
||||
(let ([line (car args)])
|
||||
(if (pair? line)
|
||||
(case (car line)
|
||||
[(once-each once-any multi)
|
||||
(loop (cdr args)
|
||||
(append
|
||||
clauses
|
||||
(list
|
||||
(list* 'list
|
||||
(list 'quote (car line))
|
||||
(let loop ([sublines (cdr line)])
|
||||
(if (null? sublines)
|
||||
null
|
||||
(cons
|
||||
(let ([line (car sublines)])
|
||||
(let-values ([(flags rest) (extract "flag string(s)" line line)])
|
||||
(unless (or (string? flags)
|
||||
(and (list? flags)
|
||||
(andmap string? flags)))
|
||||
(serror "flag specification is not a string or sequence of strings" flags))
|
||||
(if (and (pair? rest) (eq? (car rest) '=>))
|
||||
(let ([rest (cdr rest)])
|
||||
(unless (and (list? rest) (= 2 (length rest)))
|
||||
(serror "two expressions must follow a => line" line))
|
||||
`(list ',(listify flags) ,@rest))
|
||||
(let*-values ([(formals rest) (let loop ([a null][rest rest])
|
||||
(cond
|
||||
[(null? rest) (values a null)]
|
||||
[(symbol? (car rest)) (values (append a (list (car rest))) (cdr rest))]
|
||||
[else (values a rest)]))]
|
||||
[(_) (check-formals formals)]
|
||||
[(help rest) (extract "help string" rest line)]
|
||||
[(_) (unless (string? help)
|
||||
(serror "help info is not a string" help))]
|
||||
[(expr1 rest) (extract "handler body expressions" rest line)])
|
||||
`(list ',(listify flags)
|
||||
(lambda ,(cons (gensym 'flag) formals)
|
||||
,expr1 ,@rest)
|
||||
'(,help ,@(formal-names formals)))))))
|
||||
(loop (cdr sublines)))))))))]
|
||||
[(=>)
|
||||
(when (pair? (cdr args)) (serror "=> must be the last clause"))
|
||||
`((list ,@clauses)
|
||||
,@(cdr line))]
|
||||
[(args)
|
||||
(when (pair? (cdr args)) (serror "args must be the last clause"))
|
||||
(let*-values ([(formals rest) (extract "arg-handler formals" (cdr line) line)]
|
||||
[(_) (check-formals formals)]
|
||||
[(expr1 rest) (extract "arg-handler body expressions" rest line)])
|
||||
`((list ,@clauses)
|
||||
(lambda ,(cons (gensym 'accum) formals) ,expr1 ,@rest)
|
||||
,(cons 'list (formal-names formals))))]
|
||||
[else (serror "not a once-each, once-any, multi, args, or => line" line)])
|
||||
(serror "not a once-each, once-any, multi, or args line" line)))))))))))
|
||||
293
collects/mzlib/cmdliner.ss
Normal file
293
collects/mzlib/cmdliner.ss
Normal file
|
|
@ -0,0 +1,293 @@
|
|||
|
||||
(unit/sig
|
||||
mzlib:command-line^
|
||||
(import)
|
||||
|
||||
(define number-regexp (regexp "^[-+][0-9]*(|[.][0-9]*)$"))
|
||||
|
||||
(define print-args
|
||||
(lambda (port l f)
|
||||
(let loop ([l l][a (letrec ([a (arity f)]
|
||||
[a-c (lambda (a)
|
||||
(cond
|
||||
[(number? a) (cons (sub1 a) (sub1 a))]
|
||||
[(arity-at-least? a)
|
||||
(let ([v (sub1 (arity-at-least-value a))])
|
||||
(cons v v))]
|
||||
[else (let ([r (map a-c a)])
|
||||
(cons (apply min (map car r))
|
||||
(apply max (map cdr r))))]))])
|
||||
(a-c a))])
|
||||
(unless (null? l)
|
||||
(fprintf port " ~a<~a>~a"
|
||||
(if (positive? (car a)) "" "[")
|
||||
(car l)
|
||||
(if (positive? (car a)) "" "]"))
|
||||
(unless (positive? (cdr a))
|
||||
(fprintf port " ..."))
|
||||
(loop (cdr l) (cons (sub1 (car a)) (sub1 (cdr a))))))))
|
||||
|
||||
(define (procedure-arity-includes-at-least? p n)
|
||||
(letrec ([a-c
|
||||
(lambda (a)
|
||||
(cond
|
||||
[(number? a) (>= a n)]
|
||||
[(arity-at-least? a) #t]
|
||||
[else (ormap a-c a)]))])
|
||||
(a-c (arity p))))
|
||||
|
||||
(define parse-command-line
|
||||
(case-lambda
|
||||
[(program arguments table finish finish-help)
|
||||
(parse-command-line program arguments table finish finish-help
|
||||
(lambda (s)
|
||||
(display s)
|
||||
(exit 0)))]
|
||||
[(program arguments table finish finish-help help)
|
||||
(parse-command-line program arguments table finish finish-help help
|
||||
(lambda (flag)
|
||||
(error (string->symbol program) "unknown flag: ~s" flag)))]
|
||||
[(program arguments table finish finish-help help unknown-flag)
|
||||
(unless (string? program)
|
||||
(raise-type-error 'parse-command-line "program name string" program))
|
||||
(unless (and (vector? arguments)
|
||||
(andmap string? (vector->list arguments)))
|
||||
(raise-type-error 'parse-command-line "argument vector of strings" arguments))
|
||||
(unless (and (list? table)
|
||||
(let ([bad-table
|
||||
(lambda (reason)
|
||||
(raise-type-error 'parse-command-line
|
||||
(format "table as a list of flag-list/procedure pairs (~a)"
|
||||
reason)
|
||||
table))])
|
||||
(andmap (lambda (spec)
|
||||
(and (or (and (list? spec) (pair? spec))
|
||||
(bad-table (format "spec-set must be a non-empty list: ~a" spec)))
|
||||
(or (memq (car spec) '(once-any once-each multi))
|
||||
(bad-table (format "spec-set type must be 'once-any, 'once-each, or 'multi: ~a"
|
||||
(car spec))))
|
||||
(andmap (lambda (line)
|
||||
(and (or (and (list? line) (= (length line) 3))
|
||||
(bad-table (format "spec-line must be a list of at three items: ~e" line)))
|
||||
(or (list? (car line))
|
||||
(bad-table (format "flags part of a spec-line must be a list: ~e" (car line))))
|
||||
(andmap
|
||||
(lambda (flag)
|
||||
(or (string? flag)
|
||||
(bad-table (format "flag must be a string: ~e" flag)))
|
||||
(or (and (or (regexp-match "^-[^-]$" flag)
|
||||
(regexp-match "^[+][^+]$" flag)
|
||||
(regexp-match "^--." flag)
|
||||
(regexp-match "^[+][+]." flag))
|
||||
(not (or (regexp-match "^--help$" flag)
|
||||
(regexp-match "^-h$" flag)
|
||||
(regexp-match number-regexp flag))))
|
||||
(bad-table (format "no ill-formed or pre-defined flags: ~e" flag))))
|
||||
(car line))
|
||||
(or (procedure? (cadr line))
|
||||
(bad-table (format "second item in a spec-line must be a procedure: ~e" (cadr line))))
|
||||
(let ([a (arity (cadr line))])
|
||||
(or (and (number? a)
|
||||
(or (>= a 1)
|
||||
(bad-table (format "flag handler procedure must take at least 1 argument: ~e"
|
||||
(cadr line)))))
|
||||
(arity-at-least? a)
|
||||
(bad-table (format "flag handler procedure cannot have multiple cases: ~e" (cadr line)))))
|
||||
(or (and (list? (caddr line))
|
||||
(andmap string? (caddr line)))
|
||||
(bad-table (format "spec-line help section must be a list of strings")))
|
||||
|
||||
(or (let ([l (length (caddr line))]
|
||||
[a (arity (cadr line))])
|
||||
(if (number? a)
|
||||
(= a l)
|
||||
(and (>= l 1)
|
||||
(>= l (arity-at-least-value a)))))
|
||||
(bad-table (format "spec-line help list strings must match procedure arguments")))))
|
||||
(cdr spec))))
|
||||
table)))
|
||||
(raise-type-error 'parse-command-line "table of spec sets" table))
|
||||
(unless (and (procedure? finish)
|
||||
(procedure-arity-includes-at-least? finish 1))
|
||||
(raise-type-error 'parse-command-line "finish procedure accepting at least 1 argument" finish))
|
||||
(unless (and (list? finish-help) (andmap string? finish-help))
|
||||
(raise-type-error 'parse-command-line "argument help list of strings" finish-help))
|
||||
(unless (and (procedure? help) (procedure-arity-includes? help 1))
|
||||
(raise-type-error 'parse-command-line "help procedure of arity 1" help))
|
||||
(unless (and (procedure? unknown-flag) (procedure-arity-includes? unknown-flag 1)
|
||||
(let ([a (arity unknown-flag)])
|
||||
(or (number? a) (arity-at-least? a))))
|
||||
(raise-type-error 'parse-command-line "unknown-flag procedure of simple arity, accepting 1 argument (an perhaps more)" unknown-flag))
|
||||
|
||||
(letrec ([a (arity finish)]
|
||||
[l (length finish-help)]
|
||||
[a-c (lambda (a)
|
||||
(or (and (number? a) (sub1 a))
|
||||
(and (arity-at-least? a)
|
||||
(max 1 (arity-at-least-value a)))
|
||||
(and (list? a) (apply max (map a-c a)))))])
|
||||
(unless (= (a-c a) l)
|
||||
(error 'parse-command-line "the length of the argument help string list does not match the arity of the finish procedure")))
|
||||
|
||||
(let* ([once-spec-set
|
||||
(lambda (lines)
|
||||
(let ([set (cons #f (apply append (map car lines)))])
|
||||
(map
|
||||
(lambda (line) (cons set line))
|
||||
lines)))]
|
||||
[table
|
||||
(apply
|
||||
append
|
||||
(list
|
||||
(list #f (list "--help" "-h")
|
||||
(lambda (f)
|
||||
(let* ([sp (open-output-string)])
|
||||
(fprintf sp "~a~a" program
|
||||
(if (null? table)
|
||||
""
|
||||
" [ <flag> ... ]"))
|
||||
(print-args sp finish-help finish)
|
||||
(fprintf sp "~n where <flag> is one of~n ")
|
||||
(for-each
|
||||
(lambda (set)
|
||||
(for-each
|
||||
(lambda (line)
|
||||
(let loop ([flags (car line)])
|
||||
(let ([flag (car flags)])
|
||||
(fprintf sp " ~a" flag)
|
||||
(print-args sp (cdaddr line) (cadr line)))
|
||||
(unless (null? (cdr flags))
|
||||
(fprintf sp ",")
|
||||
(loop (cdr flags))))
|
||||
(fprintf sp " : ~a~n " (caaddr line)))
|
||||
(cdr set)))
|
||||
table) ; the original table
|
||||
(fprintf sp " --help, -h : Show this help~n")
|
||||
(fprintf sp " -- : Do not treat any remaining argument as a flag (at this level)~n")
|
||||
(fprintf sp " Multiple single-letter flags can be combined after one `-'.~n E.g.: `-h-' is the same as `-h --'~n")
|
||||
(help (get-output-string sp))))
|
||||
(list "Help")))
|
||||
(map
|
||||
(lambda (spec)
|
||||
(cond
|
||||
[(eq? (car spec) 'once-each)
|
||||
(apply
|
||||
append
|
||||
(map
|
||||
(lambda (line) (once-spec-set (list line)))
|
||||
(cdr spec)))]
|
||||
[(eq? (car spec) 'once-any)
|
||||
(once-spec-set (cdr spec))]
|
||||
[(eq? (car spec) 'multi)
|
||||
(map
|
||||
(lambda (line) (cons #f line))
|
||||
(cdr spec))]))
|
||||
table))]
|
||||
[done
|
||||
(lambda (args r-acc)
|
||||
(let ([options (reverse r-acc)]
|
||||
[c (length args)])
|
||||
(if (procedure-arity-includes? finish (add1 c))
|
||||
(apply finish options args)
|
||||
(error (string->symbol program)
|
||||
(format "expects~a on the command line, given ~a argument~a~a"
|
||||
(if (null? finish-help)
|
||||
" no arguments"
|
||||
(let ([s (open-output-string)])
|
||||
(parameterize ([current-output-port s])
|
||||
(print-args s finish-help finish))
|
||||
(let ([s (get-output-string s)])
|
||||
(if (equal? 2 (arity finish))
|
||||
(format " 1~a" s)
|
||||
s))))
|
||||
c
|
||||
(cond
|
||||
[(zero? c) "s"]
|
||||
[(= c 1) ": "]
|
||||
[else "s: "])
|
||||
(let loop ([args args])
|
||||
(if (null? args)
|
||||
""
|
||||
(string-append (car args) " " (loop (cdr args))))))))))]
|
||||
[call-handler
|
||||
(lambda (handler flag args r-acc k)
|
||||
(let* ([a (arity handler)]
|
||||
[remaining (length args)]
|
||||
[needed (if (number? a)
|
||||
(sub1 a)
|
||||
(sub1 (arity-at-least-value a)))]
|
||||
[use (if (number? a)
|
||||
(sub1 a)
|
||||
remaining)])
|
||||
(if (< remaining needed)
|
||||
(error (string->symbol program)
|
||||
"the ~s flag needs ~a argument~a, but only ~a provided"
|
||||
flag needed (if (> needed 1) "s" "")
|
||||
remaining)
|
||||
(let ([v (apply handler
|
||||
flag
|
||||
(let loop ([n use][args args])
|
||||
(if (zero? n)
|
||||
null
|
||||
(cons (car args)
|
||||
(loop (sub1 n) (cdr args))))))])
|
||||
(k (list-tail args use)
|
||||
(if (void? v)
|
||||
r-acc
|
||||
(cons v r-acc)))))))]
|
||||
[handle-flag
|
||||
(lambda (flag args r-acc orig-multi k)
|
||||
(let loop ([table table])
|
||||
(cond
|
||||
[(null? table)
|
||||
(call-handler unknown-flag flag args r-acc k)]
|
||||
[(member flag (cadar table))
|
||||
(when (caar table)
|
||||
(let ([set (caar table)])
|
||||
(if (car set)
|
||||
(let ([flags (cdr set)])
|
||||
(error (string->symbol program)
|
||||
(let ([s (if (= 1 (length flags))
|
||||
(format "the ~a flag can only be specified once" (car flags))
|
||||
(format "only one instance of one flag from ~a is allowed" flags))])
|
||||
(if orig-multi
|
||||
(format "~a; note that ~s is shorthand for ~s, in contrast to ~s"
|
||||
s
|
||||
orig-multi
|
||||
(let loop ([prefix (string-ref orig-multi 0)]
|
||||
[flags (string->list (substring orig-multi 1 (string-length orig-multi)))]
|
||||
[sep ""])
|
||||
(if (null? flags)
|
||||
""
|
||||
(format "~a~a~a~a" sep prefix (car flags)
|
||||
(loop prefix (cdr flags) " "))))
|
||||
(string-append (substring orig-multi 0 1) orig-multi))
|
||||
s))))
|
||||
(set-car! set #t))))
|
||||
(call-handler (caddar table) flag args r-acc k)]
|
||||
[else (loop (cdr table))])))])
|
||||
(let loop ([args (vector->list arguments)][r-acc null])
|
||||
(if (null? args)
|
||||
(done args r-acc)
|
||||
(let ([arg (car args)]
|
||||
[rest (cdr args)])
|
||||
(cond
|
||||
[(regexp-match number-regexp arg)
|
||||
(done args r-acc)]
|
||||
[(regexp-match "^--$" arg)
|
||||
(done (cdr args) r-acc)]
|
||||
[(regexp-match "^[-+][-+]" arg)
|
||||
(handle-flag arg rest r-acc #f loop)]
|
||||
[(regexp-match "^[-+]." arg)
|
||||
(let a-loop ([s (string->list (substring arg 1 (string-length arg)))]
|
||||
[rest rest]
|
||||
[r-acc r-acc])
|
||||
(if (null? s)
|
||||
(loop rest r-acc)
|
||||
(handle-flag (string (string-ref arg 0) (car s))
|
||||
rest r-acc
|
||||
arg
|
||||
(lambda (args r-acc)
|
||||
(a-loop (cdr s) args r-acc)))))]
|
||||
[else
|
||||
(done args r-acc)])))))])))
|
||||
3
collects/mzlib/cmdlines.ss
Normal file
3
collects/mzlib/cmdlines.ss
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
|
||||
(define-signature mzlib:command-line^
|
||||
(parse-command-line))
|
||||
7
collects/mzlib/cmdlineu.ss
Normal file
7
collects/mzlib/cmdlineu.ss
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
|
||||
(require-library "cmdlines.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "refer.ss"))
|
||||
|
||||
(define mzlib:command-line@ (require-library-unit/sig "cmdliner.ss"))
|
||||
11
collects/mzlib/compat.ss
Normal file
11
collects/mzlib/compat.ss
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
|
||||
(require-library "compatu.ss")
|
||||
(require-library "functio.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:compat^
|
||||
mzlib:compat@
|
||||
#f
|
||||
mzlib:function^)
|
||||
9
collects/mzlib/compatm.ss
Normal file
9
collects/mzlib/compatm.ss
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
|
||||
(define-macro defmacro
|
||||
(lambda (name args . body)
|
||||
`(define-macro ,name (lambda ,args ,@body))))
|
||||
|
||||
(define-macro letmacro
|
||||
(lambda (name args mbody . body)
|
||||
`(let-macro ,name (lambda ,args ,mbody)
|
||||
,body)))
|
||||
73
collects/mzlib/compatr.ss
Normal file
73
collects/mzlib/compatr.ss
Normal file
|
|
@ -0,0 +1,73 @@
|
|||
(unit/sig
|
||||
mzlib:compat^
|
||||
(import mzlib:function^)
|
||||
|
||||
(define 1+ add1)
|
||||
(define 1- sub1)
|
||||
(define #%1+ #%add1)
|
||||
(define #%1- #%sub1)
|
||||
|
||||
(define =? =)
|
||||
(define <? <)
|
||||
(define >? >)
|
||||
(define <=? <)
|
||||
(define >=? >)
|
||||
|
||||
(define atom? (lambda (v) (not (pair? v))))
|
||||
|
||||
(define gentemp gensym)
|
||||
|
||||
(define sort ; Chez argument order
|
||||
(lambda (less-than? l)
|
||||
(quicksort l less-than?)))
|
||||
|
||||
(define bound? defined?)
|
||||
|
||||
(define flush-output-port flush-output)
|
||||
|
||||
(define real-time current-milliseconds)
|
||||
|
||||
(define getprop (void))
|
||||
(define putprop (void))
|
||||
(let ([table (make-hash-table)])
|
||||
(letrec ([gp
|
||||
(case-lambda
|
||||
[(k prop) (gp k prop #f)]
|
||||
[(k prop def)
|
||||
(let ([al (hash-table-get table k (lambda () #f))])
|
||||
(if al
|
||||
(let ([v (assq prop al)])
|
||||
(if v
|
||||
(cdr v)
|
||||
def))
|
||||
def))])]
|
||||
[pp
|
||||
(lambda (k prop nv)
|
||||
(let ([al (hash-table-get table k (lambda () '()))])
|
||||
(let ([v (assq prop al)])
|
||||
(if v
|
||||
(set-cdr! v nv)
|
||||
(hash-table-put! table k (cons (cons prop nv) al))))))])
|
||||
(set! getprop gp)
|
||||
(set! putprop pp)))
|
||||
|
||||
; Chez's new-cafe
|
||||
(define new-cafe
|
||||
(letrec ([nc
|
||||
(case-lambda
|
||||
[() (nc (current-eval))]
|
||||
[(eval)
|
||||
(let/ec escape
|
||||
(let ([orig-exit (exit-handler)]
|
||||
[orig-eval (current-eval)])
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(current-eval eval)
|
||||
(exit-handler
|
||||
(lambda (v) (escape v))))
|
||||
read-eval-print-loop
|
||||
(lambda ()
|
||||
(current-eval orig-eval)
|
||||
(exit-handler orig-exit)))))])])
|
||||
nc))
|
||||
)
|
||||
16
collects/mzlib/compats.ss
Normal file
16
collects/mzlib/compats.ss
Normal file
|
|
@ -0,0 +1,16 @@
|
|||
|
||||
(begin-elaboration-time
|
||||
(require-library "functios.ss"))
|
||||
|
||||
(define-signature mzlib:compat^
|
||||
(real-time
|
||||
1+ 1- #%1+ #%1-
|
||||
>=? <=? >? <? =?
|
||||
flush-output-port
|
||||
bound?
|
||||
sort
|
||||
gentemp
|
||||
atom?
|
||||
putprop getprop
|
||||
new-cafe))
|
||||
|
||||
11
collects/mzlib/compatu.ss
Normal file
11
collects/mzlib/compatu.ss
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
|
||||
(begin-elaboration-time
|
||||
(require-library "compatm.ss"))
|
||||
|
||||
(require-library "compats.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "refer.ss"))
|
||||
|
||||
(define mzlib:compat@ (require-library-unit/sig "compatr.ss"))
|
||||
|
||||
8
collects/mzlib/compile.ss
Normal file
8
collects/mzlib/compile.ss
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
|
||||
(require-library "compileu.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:compile^
|
||||
mzlib:compile@)
|
||||
327
collects/mzlib/compiler.ss
Normal file
327
collects/mzlib/compiler.ss
Normal file
|
|
@ -0,0 +1,327 @@
|
|||
(compound-unit/sig
|
||||
(import)
|
||||
(link
|
||||
[referf
|
||||
: (require-unit reference-file)
|
||||
((unit->unit/sig (require-relative-library "referf.ss")
|
||||
()
|
||||
(require-unit reference-file)))]
|
||||
[compile
|
||||
: mzlib:compile^
|
||||
((unit/sig mzlib:compile^
|
||||
(import (r : (require-unit reference-file)))
|
||||
|
||||
(define identity (lambda (x n) x))
|
||||
|
||||
; top-level begin-elaboration-time => begin-expansion-time
|
||||
; nested begin-elaboration-time => begin
|
||||
; require-XXX => usual expansion w/o string check
|
||||
(define -require-library-unit/sig (r:require-unit #f #t #f #t 'require-library-unit/sig))
|
||||
(define -require-library-unit (r:require-unit #f #t #f #f 'require-library-unit))
|
||||
(define -require-relative-library-unit/sig (r:require-unit #f #t #t #t 'require-relative-library-unit/sig))
|
||||
(define -require-relative-library-unit (r:require-unit #f #t #t #f 'require-relative-library-unit))
|
||||
(define -require-unit/sig (r:require-unit #f #f #f #t 'require-unit/sig))
|
||||
(define -require-unit (r:require-unit #f #f #f #f 'require-unit))
|
||||
(define -reference-file (r:reference-file #f #f #f))
|
||||
(define -require-library (r:reference-file #f #t #f))
|
||||
(define -require-relative-library (r:reference-file #f #t #t))
|
||||
(define make--begin-elaboration-time
|
||||
(lambda (do?)
|
||||
(lambda body
|
||||
(when do?
|
||||
(eval `(begin ,@body)))
|
||||
`(#%eval (#%eval (#%quote (begin ,@body)))))))
|
||||
|
||||
(define make-compile-namespace
|
||||
(lambda (flags preserve-elab? do-elab? preserve-constr? do-constr?)
|
||||
(let ([n (apply make-namespace flags)]
|
||||
[gvs (make-global-value-list)])
|
||||
(parameterize ([current-namespace n])
|
||||
(for-each
|
||||
(lambda (gvp)
|
||||
(unless (defined? (car gvp))
|
||||
(eval `(define ,(car gvp) (quote ,(cdr gvp))))))
|
||||
gvs)
|
||||
(setup-preserving-compile-namespace preserve-elab? do-elab? preserve-constr? do-constr?))
|
||||
n)))
|
||||
|
||||
(define (setup-preserving-compile-namespace preserve-elab? do-elab? preserve-constr? do-constr?)
|
||||
(when (or preserve-elab? do-elab? preserve-constr? do-constr?)
|
||||
(eval `(begin
|
||||
(require-library "refer.ss")
|
||||
(define-macro reference-file ,-reference-file)
|
||||
(define-macro require-unit/sig ,-require-unit/sig)
|
||||
(define-macro require-unit ,-require-unit)
|
||||
(define-macro require-library-unit/sig ,-require-library-unit/sig)
|
||||
(define-macro require-library-unit ,-require-library-unit)
|
||||
(define-macro require-library ,-require-library)
|
||||
(define-macro require-relative-library-unit/sig ,-require-relative-library-unit/sig)
|
||||
(define-macro require-relative-library-unit ,-require-relative-library-unit)
|
||||
(define-macro require-relative-library ,-require-relative-library)
|
||||
,@(let ([e (if preserve-elab?
|
||||
`((define-macro begin-elaboration-time ,(make--begin-elaboration-time do-elab?)))
|
||||
null)]
|
||||
[c (if preserve-constr?
|
||||
`((define-macro begin-construction-time ,(make--begin-elaboration-time do-constr?)))
|
||||
null)])
|
||||
(append e c))))))
|
||||
|
||||
(define compile-file
|
||||
(case-lambda
|
||||
[(srcs dest) (compile-file srcs dest null identity)]
|
||||
[(srcs dest flags) (compile-file srcs dest flags identity)]
|
||||
[(srcs dest flags preprocessor)
|
||||
(unless (or (string? srcs)
|
||||
(input-port? srcs)
|
||||
(and (list? srcs) (andmap (lambda (x) (or (string? x)
|
||||
(input-port? x)))
|
||||
srcs)))
|
||||
(raise-type-error 'compile-file
|
||||
"string, input-port, or list of strings or input-ports"
|
||||
srcs))
|
||||
(unless (or (string? dest) (output-port? dest))
|
||||
(raise-type-error 'compile-file "string or output-port" dest))
|
||||
(unless (and (list flags)
|
||||
(andmap (lambda (s)
|
||||
(member s '(ignore-macro-definitions
|
||||
strip-macro-definitions
|
||||
expand-load
|
||||
use-current-namespace
|
||||
ignore-require-library
|
||||
expand-require-library
|
||||
no-warnings
|
||||
only-expand
|
||||
preserve-elaborations
|
||||
also-preserve-elaborations
|
||||
preserve-constructions
|
||||
also-preserve-constructions)))
|
||||
flags))
|
||||
(raise-type-error 'compile-file "list of flag symbols" flags))
|
||||
(unless (and (procedure? preprocessor)
|
||||
(procedure-arity-includes? preprocessor 2))
|
||||
(raise-type-error 'compile-file "procedure (arity 2)" preprocessor))
|
||||
(let* ([do-macros? (not (member 'ignore-macro-definitions flags))]
|
||||
[keep-macros? (not (member 'strip-macro-definitions flags))]
|
||||
[expand-load? (member 'expand-load flags)]
|
||||
[expand-rl? (member 'expand-require-library flags)]
|
||||
[ignore-rl? (member 'ignore-require-library flags)]
|
||||
[expand-only? (member 'only-expand flags)]
|
||||
[also-keep-elab? (member 'also-preserve-elaborations flags)]
|
||||
[keep-elab? (or also-keep-elab? (member 'preserve-elaborations flags))]
|
||||
[also-keep-constr? (member 'also-preserve-constructions flags)]
|
||||
[keep-constr? (or also-keep-elab? (member 'preserve-constructions flags))]
|
||||
[namespace (if (member 'use-current-namespace flags)
|
||||
(begin
|
||||
(setup-preserving-compile-namespace
|
||||
keep-elab?
|
||||
also-keep-elab?
|
||||
keep-constr?
|
||||
also-keep-constr?)
|
||||
(current-namespace))
|
||||
(make-compile-namespace
|
||||
(if (built-in-name 'wx:frame%) ; HACK!!!
|
||||
'(wx)
|
||||
null)
|
||||
keep-elab?
|
||||
also-keep-elab?
|
||||
keep-constr?
|
||||
also-keep-constr?))]
|
||||
[required (make-hash-table)]
|
||||
[warning
|
||||
(lambda (s)
|
||||
(unless (member 'no-warnings flags)
|
||||
(fprintf (current-error-port)
|
||||
"compile-file warning: ~a~n"
|
||||
s)))])
|
||||
(let ([out (if (output-port? dest)
|
||||
dest
|
||||
(open-output-file dest 'truncate/replace))])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(when keep-elab?
|
||||
(display "'e " out)) ; mark of an elaboration-time file
|
||||
(write
|
||||
`(#%if (#%not (#%string=? (#%version) ,(version)))
|
||||
(#%error (#%quote ,(if (string? srcs)
|
||||
(string->symbol srcs)
|
||||
'compiled-file))
|
||||
,(string-append
|
||||
"compiled for MzScheme version "
|
||||
(version)
|
||||
", not ~a")
|
||||
(#%version)))
|
||||
out)
|
||||
(newline out)
|
||||
(let src-loop ([srcs srcs])
|
||||
(unless (null? srcs)
|
||||
(let*-values ([(src next-srcs)
|
||||
(if (list? srcs)
|
||||
(values (car srcs) (cdr srcs))
|
||||
(values srcs null))]
|
||||
[(in) (if (input-port? src)
|
||||
src
|
||||
(open-input-file src))])
|
||||
(parameterize ([current-load-relative-directory
|
||||
(let ([clrp (current-load-relative-directory)])
|
||||
(if (string? src)
|
||||
(let-values ([(base name dir?)
|
||||
(split-path (path->complete-path
|
||||
src
|
||||
(or clrp
|
||||
(current-directory))))])
|
||||
base)
|
||||
clrp))])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(let loop ([in in])
|
||||
(let ([s (read in)])
|
||||
(if (not (eof-object? s))
|
||||
(let* ([do-defmacro
|
||||
(lambda (s)
|
||||
(let ([m (if (pair? (cdr s))
|
||||
(cadr s)
|
||||
#f)])
|
||||
(if (symbol? m)
|
||||
(parameterize ([current-namespace namespace])
|
||||
(eval s)
|
||||
#f)
|
||||
(begin
|
||||
(warning
|
||||
(format
|
||||
"define-macro expression is ill-formed: ~s"
|
||||
s))
|
||||
#f))))]
|
||||
[do-load
|
||||
(lambda (s cd? rel?)
|
||||
(let ([name (if (pair? (cdr s))
|
||||
(cadr s)
|
||||
#f)])
|
||||
(if (and (string? name)
|
||||
(null? (cddr s)))
|
||||
(let*-values ([(name) (if (and rel?
|
||||
(relative-path? name)
|
||||
(current-load-relative-directory))
|
||||
(build-path (current-load-relative-directory) name)
|
||||
name)]
|
||||
[(base nameonly dir?) (split-path name)]
|
||||
[(cd?) (and cd?
|
||||
(string? base))]
|
||||
[(orig-dir) (and cd?
|
||||
(current-directory))])
|
||||
(if cd?
|
||||
(current-directory
|
||||
base))
|
||||
(let ([in (open-input-file
|
||||
(if cd?
|
||||
nameonly
|
||||
name))])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(parameterize ([current-load-relative-directory
|
||||
(if (string? base)
|
||||
base
|
||||
(current-load-relative-directory))])
|
||||
(loop in))
|
||||
#t)
|
||||
(lambda ()
|
||||
(close-input-port in)
|
||||
(if cd?
|
||||
(current-directory
|
||||
orig-dir)))))
|
||||
#t)
|
||||
(begin
|
||||
(warning
|
||||
(format
|
||||
"load expression is ill-formed or ~a: ~s"
|
||||
"contains an expression for file name"
|
||||
s))
|
||||
#f))))]
|
||||
[find-library
|
||||
(lambda (collection name)
|
||||
(let ([all-paths (current-library-collection-paths)])
|
||||
(let loop ([paths all-paths])
|
||||
(if (null? paths)
|
||||
(error 'compile-file "require-library: collection not found: ~s (in any of ~s)"
|
||||
collection all-paths)
|
||||
(let ([dir (build-path (car paths) collection)])
|
||||
(if (directory-exists? dir)
|
||||
(build-path dir name)
|
||||
(loop (cdr paths))))))))]
|
||||
[do-rl
|
||||
(lambda (s)
|
||||
(if (and (pair? (cdr s))
|
||||
(string? (cadr s))
|
||||
(or (null? (cddr s))
|
||||
(and (pair? (cddr s))
|
||||
(string? (caddr s))
|
||||
(null? (cdddr s)))))
|
||||
(let ([name (cadr s)]
|
||||
[collection (if (null? (cddr s))
|
||||
"mzlib"
|
||||
(caddr s))])
|
||||
(if expand-rl?
|
||||
(let* ([key (string->symbol (string-append collection (string #\null) name))])
|
||||
(if (hash-table-get required key (lambda () #f))
|
||||
#t
|
||||
(let ([fullname (find-library collection name)])
|
||||
(hash-table-put! required key #t)
|
||||
(do-load s #f #t)
|
||||
#t)))
|
||||
(parameterize ([current-namespace namespace])
|
||||
(eval `(require-library/proc ,name
|
||||
,collection))
|
||||
#f)))
|
||||
(begin
|
||||
(warning
|
||||
(format
|
||||
"require-library expression is ill-formed or ~a: ~s"
|
||||
"contains an expression for library/collection name"
|
||||
s))
|
||||
#f)))]
|
||||
[s (let ([p (preprocessor s namespace)])
|
||||
(parameterize ([current-namespace namespace])
|
||||
(expand-defmacro p)))]
|
||||
[v-c (if expand-only?
|
||||
s
|
||||
(if (void? s)
|
||||
(compile '(#%void))
|
||||
(parameterize ([current-namespace namespace])
|
||||
(compile s))))]
|
||||
[v (if (pair? s)
|
||||
(let ([t (car s)])
|
||||
(case t
|
||||
[(define-macro
|
||||
define-id-macro
|
||||
define-expansion-time
|
||||
#%define-macro
|
||||
#%define-id-macro
|
||||
#%define-expansion-time)
|
||||
(and do-macros? (or (do-defmacro s) (not keep-macros?)))]
|
||||
[(load #%load)
|
||||
(and expand-load? (do-load s #f #f))]
|
||||
[(load/cd #%load/cd)
|
||||
(and expand-load? (do-load s #t #f))]
|
||||
[(load-relative #%load-relative)
|
||||
(and expand-load? (do-load s #f #t))]
|
||||
[(require-library/proc #%require-library/proc)
|
||||
(and (not ignore-rl?) (do-rl s))]
|
||||
[else #f]))
|
||||
#f)])
|
||||
(unless v
|
||||
(write v-c out))
|
||||
(newline out)
|
||||
(loop in))))))
|
||||
(lambda ()
|
||||
(if (input-port? src)
|
||||
(void)
|
||||
(close-input-port in)))))
|
||||
(src-loop next-srcs)))))
|
||||
(lambda ()
|
||||
(if (output-port? dest)
|
||||
(void)
|
||||
(close-output-port out))))))])))
|
||||
referf)])
|
||||
(export (open compile)))
|
||||
3
collects/mzlib/compiles.ss
Normal file
3
collects/mzlib/compiles.ss
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
|
||||
(define-signature mzlib:compile^
|
||||
(compile-file))
|
||||
10
collects/mzlib/compileu.ss
Normal file
10
collects/mzlib/compileu.ss
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
|
||||
(require-library "compiles.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "refer.ss"))
|
||||
|
||||
(define mzlib:compile@ (require-library-unit/sig "compiler.ss"))
|
||||
|
||||
|
||||
|
||||
13
collects/mzlib/core.ss
Normal file
13
collects/mzlib/core.ss
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
|
||||
; Load core mzlib
|
||||
|
||||
(require-relative-library "coreu.ss")
|
||||
|
||||
(require-relative-library "pretty.ss")
|
||||
(require-relative-library "file.ss")
|
||||
(require-relative-library "function.ss")
|
||||
(require-relative-library "string.ss")
|
||||
(require-relative-library "compile.ss")
|
||||
(require-relative-library "math.ss")
|
||||
(require-relative-library "thread.ss")
|
||||
|
||||
17
collects/mzlib/coreflatr.ss
Normal file
17
collects/mzlib/coreflatr.ss
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
|
||||
(compound-unit/sig
|
||||
(import)
|
||||
(link [pretty-print : mzlib:pretty-print^ ((require-library-unit/sig "prettyr.ss"))]
|
||||
[file : mzlib:file^ ((require-library-unit/sig "filer.ss") string function)]
|
||||
[function : mzlib:function^ ((require-library-unit/sig "functior.ss"))]
|
||||
[string : mzlib:string^ ((require-library-unit/sig "stringr.ss"))]
|
||||
[compile : mzlib:compile^ ((require-library-unit/sig "compiler.ss"))]
|
||||
[math : mzlib:math^ ((require-library-unit/sig "mathr.ss"))]
|
||||
[thread : mzlib:thread^ ((require-library-unit/sig "threadr.ss"))])
|
||||
(export (open pretty-print)
|
||||
(open file)
|
||||
(open function)
|
||||
(open string)
|
||||
(open compile)
|
||||
(open math)
|
||||
(open thread)))
|
||||
12
collects/mzlib/coreflats.ss
Normal file
12
collects/mzlib/coreflats.ss
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
|
||||
(require-library "cores.ss")
|
||||
|
||||
(define-signature mzlib:core-flat^
|
||||
((open mzlib:pretty-print^)
|
||||
(open mzlib:file^)
|
||||
(open mzlib:function^)
|
||||
(open mzlib:string^)
|
||||
(open mzlib:compile^)
|
||||
(open mzlib:math^)
|
||||
(open mzlib:thread^)))
|
||||
|
||||
13
collects/mzlib/corem.ss
Normal file
13
collects/mzlib/corem.ss
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
|
||||
; Loads macro parts of MzLib:
|
||||
|
||||
(require-library "refer.ss")
|
||||
|
||||
(require-relative-library "spidey.ss")
|
||||
|
||||
(require-relative-library "macro.ss")
|
||||
|
||||
(require-relative-library "match.ss")
|
||||
(require-relative-library "defstru.ss")
|
||||
(require-relative-library "compatm.ss")
|
||||
(require-relative-library "shared.ss")
|
||||
17
collects/mzlib/corer.ss
Normal file
17
collects/mzlib/corer.ss
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
|
||||
(compound-unit/sig
|
||||
(import)
|
||||
(link [pretty-print : mzlib:pretty-print^ ((require-library-unit/sig "prettyr.ss"))]
|
||||
[file : mzlib:file^ ((require-library-unit/sig "filer.ss") string function)]
|
||||
[function : mzlib:function^ ((require-library-unit/sig "functior.ss"))]
|
||||
[string : mzlib:string^ ((require-library-unit/sig "stringr.ss"))]
|
||||
[compile : mzlib:compile^ ((require-library-unit/sig "compiler.ss"))]
|
||||
[math : mzlib:math^ ((require-library-unit/sig "mathr.ss"))]
|
||||
[thread : mzlib:thread^ ((require-library-unit/sig "threadr.ss"))])
|
||||
(export (unit pretty-print)
|
||||
(unit file)
|
||||
(unit function)
|
||||
(unit string)
|
||||
(unit compile)
|
||||
(unit math)
|
||||
(unit thread)))
|
||||
21
collects/mzlib/cores.ss
Normal file
21
collects/mzlib/cores.ss
Normal file
|
|
@ -0,0 +1,21 @@
|
|||
|
||||
(begin-elaboration-time
|
||||
(require-relative-library "prettys.ss")
|
||||
(require-relative-library "files.ss")
|
||||
(require-relative-library "functios.ss")
|
||||
(require-relative-library "strings.ss")
|
||||
(require-relative-library "compiles.ss")
|
||||
(require-relative-library "maths.ss")
|
||||
(require-relative-library "threads.ss")
|
||||
|
||||
(require-library "refer.ss"))
|
||||
|
||||
(define-signature mzlib:core^
|
||||
((unit pretty-print : mzlib:pretty-print^)
|
||||
(unit file : mzlib:file^)
|
||||
(unit function : mzlib:function^)
|
||||
(unit string : mzlib:string^)
|
||||
(unit compile : mzlib:compile^)
|
||||
(unit math : mzlib:math^)
|
||||
(unit thread : mzlib:thread^)))
|
||||
|
||||
20
collects/mzlib/coreu.ss
Normal file
20
collects/mzlib/coreu.ss
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
|
||||
; Load core mzlib
|
||||
|
||||
(require-relative-library "corem.ss")
|
||||
|
||||
(require-relative-library "prettyu.ss")
|
||||
(require-relative-library "fileu.ss")
|
||||
(require-relative-library "functiou.ss")
|
||||
(require-relative-library "compatu.ss")
|
||||
(require-relative-library "stringu.ss")
|
||||
(require-relative-library "compileu.ss")
|
||||
(require-relative-library "mathu.ss")
|
||||
(require-relative-library "threadu.ss")
|
||||
|
||||
(require-relative-library "cores.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "refer.ss"))
|
||||
|
||||
(define mzlib:core@ (require-relative-library-unit/sig "corer.ss"))
|
||||
11
collects/mzlib/date.ss
Normal file
11
collects/mzlib/date.ss
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
|
||||
(require-library "dateu.ss")
|
||||
(require-library "functio.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:date^
|
||||
mzlib:date@
|
||||
#f
|
||||
mzlib:function^)
|
||||
359
collects/mzlib/dater.ss
Normal file
359
collects/mzlib/dater.ss
Normal file
|
|
@ -0,0 +1,359 @@
|
|||
(unit/sig mzlib:date^
|
||||
(import mzlib:function^)
|
||||
|
||||
;; Support for Julian calendar added by Shriram;
|
||||
;; current version only works until 2099 CE Gregorian
|
||||
|
||||
#|
|
||||
|
||||
(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 legal-formats
|
||||
(list 'american 'chinese 'german 'indian 'irish 'julian))
|
||||
|
||||
(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 day/number->string
|
||||
(lambda (x)
|
||||
(case x
|
||||
[(0) "Sunday"]
|
||||
[(1) "Monday"]
|
||||
[(2) "Tuesday"]
|
||||
[(3) "Wednesday"]
|
||||
[(4) "Thursday"]
|
||||
[(5) "Friday"]
|
||||
[(6) "Saturday"]
|
||||
[else ""])))
|
||||
|
||||
(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 (if (> hour 12)
|
||||
(number->string (- hour 12))
|
||||
(number->string 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
|
||||
" xingqi" (case (date-week-day date)
|
||||
[(0) "ri"]
|
||||
[(1) "yi"]
|
||||
[(2) "er"]
|
||||
[(3) "san"]
|
||||
[(4) "si"]
|
||||
[(5) "wu"]
|
||||
[(6) "liu"]
|
||||
[else ""]))
|
||||
(list " " hour24 ":" minute ":" second))]
|
||||
[(indian)
|
||||
(values (list day "-" num-month "-" year)
|
||||
(list " " hour12 ":" minute ":" second am-pm))]
|
||||
[(german)
|
||||
(values (list day ". " month " " 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))]
|
||||
[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)))))))
|
||||
|
||||
;; 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-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 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 build-date
|
||||
(lambda (second minute hour day month year dst?)
|
||||
(letrec ([week-day 0]
|
||||
[find-year-day
|
||||
(lambda (m)
|
||||
(if (= m 0)
|
||||
(sub1 day)
|
||||
(+ (days-per-month year m)
|
||||
(find-year-day (sub1 m)))))])
|
||||
(make-date second minute hour day month year
|
||||
week-day (find-year-day (sub1 month)) dst?))))
|
||||
|
||||
(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 ([void (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 ([void
|
||||
(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 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-existant 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))))))))))))
|
||||
|
||||
)
|
||||
11
collects/mzlib/dates.ss
Normal file
11
collects/mzlib/dates.ss
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
|
||||
(begin-elaboration-time
|
||||
(require-library "functios.ss"))
|
||||
|
||||
(define-signature mzlib:date^
|
||||
(date->string
|
||||
date-display-format
|
||||
find-seconds
|
||||
|
||||
date->julian/scalinger
|
||||
julian/scalinger->string))
|
||||
7
collects/mzlib/dateu.ss
Normal file
7
collects/mzlib/dateu.ss
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
|
||||
(require-library "dates.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "refer.ss"))
|
||||
|
||||
(define mzlib:date@ (require-library-unit/sig "dater.ss"))
|
||||
61
collects/mzlib/defstru.ss
Normal file
61
collects/mzlib/defstru.ss
Normal file
|
|
@ -0,0 +1,61 @@
|
|||
|
||||
|
||||
(define-macro define-structure
|
||||
(lambda rest
|
||||
`(define-const-structure ,@rest)))
|
||||
|
||||
(define-macro define-const-structure
|
||||
(lambda (name-and-fields . fields-with-defaults-list)
|
||||
(let ([fields-with-defaults
|
||||
(if (null? fields-with-defaults-list)
|
||||
fields-with-defaults-list
|
||||
(if (and (pair? fields-with-defaults-list)
|
||||
(null? (cdr fields-with-defaults-list)))
|
||||
(car fields-with-defaults-list)
|
||||
(error 'define-const-structure "bad specification: ~s"
|
||||
(cons name-and-fields fields-with-defaults-list))))]
|
||||
[strip-id
|
||||
(lambda (id)
|
||||
(cond
|
||||
[(symbol? id) id]
|
||||
[(and (pair? id)
|
||||
(pair? (cdr id))
|
||||
(null? (cddr id))
|
||||
(eq? (car id) '!)
|
||||
(symbol? (cadr id)))
|
||||
(cadr id)]
|
||||
[else
|
||||
(error 'define-const-structure "bad field name: ~a" id)]))]
|
||||
[check-id
|
||||
(lambda (x)
|
||||
(if (not (symbol? x))
|
||||
(error 'define-const-structure "bad structure name: ~a" x)
|
||||
x))])
|
||||
(if (not (list? name-and-fields))
|
||||
(error 'define-const-structure "bad structure form: ~a" name-and-fields))
|
||||
(if (not (list? fields-with-defaults))
|
||||
(error 'define-const-structure "bad defaults structure form: ~a"
|
||||
fields-with-defaults))
|
||||
(if (null? fields-with-defaults)
|
||||
`(define-struct ,(check-id (car name-and-fields))
|
||||
,(map strip-id (cdr name-and-fields)))
|
||||
(let ([gs (gensym)]
|
||||
[maker (string->symbol
|
||||
(string-append "make-"
|
||||
(symbol->string (check-id (car name-and-fields)))))]
|
||||
[args (map strip-id (cdr name-and-fields))])
|
||||
`(begin
|
||||
(define-struct ,(car name-and-fields)
|
||||
,(append args
|
||||
(map (lambda (x)
|
||||
(if (and (pair? x)
|
||||
(pair? (cdr x))
|
||||
(null? (cddr x)))
|
||||
(strip-id (car x))
|
||||
(error 'define-const-structure "bad name-value pair: ~s"
|
||||
x)))
|
||||
fields-with-defaults)))
|
||||
(let ([,gs ,maker])
|
||||
(set! ,maker
|
||||
(lambda ,args
|
||||
(,gs ,@args ,@(map cadr fields-with-defaults)))))))))))
|
||||
13
collects/mzlib/file.ss
Normal file
13
collects/mzlib/file.ss
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
|
||||
(require-library "fileu.ss")
|
||||
(require-library "functio.ss")
|
||||
(require-library "string.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:file^
|
||||
mzlib:file@
|
||||
#f
|
||||
mzlib:string^
|
||||
mzlib:function^)
|
||||
218
collects/mzlib/filer.ss
Normal file
218
collects/mzlib/filer.ss
Normal file
|
|
@ -0,0 +1,218 @@
|
|||
(unit/sig
|
||||
mzlib:file^
|
||||
(import (s : mzlib:string^) (f : mzlib:function^))
|
||||
|
||||
(define build-relative-path
|
||||
(lambda (p . args)
|
||||
(if (relative-path? p)
|
||||
(apply build-path p args)
|
||||
(error 'build-relative-path "base path ~s is absolute" p))))
|
||||
|
||||
(define build-absolute-path
|
||||
(lambda (p . args)
|
||||
(if (relative-path? p)
|
||||
(error 'build-absolute-path "base path ~s is relative" p)
|
||||
(apply build-path p args))))
|
||||
|
||||
; Note that normalize-path does not normalize the case
|
||||
(define normalize-path
|
||||
(letrec ([resolve-all
|
||||
(lambda (path wrt)
|
||||
(let ([orig-path (if (and wrt (not (complete-path? path)))
|
||||
(path->complete-path path wrt)
|
||||
path)])
|
||||
(let loop ([full-path orig-path])
|
||||
(let ([resolved (resolve-path full-path)])
|
||||
(if (string=? resolved full-path)
|
||||
(do-normalize-path resolved #f)
|
||||
(let ([path (if (relative-path? resolved)
|
||||
(build-path
|
||||
(let-values ([(base name dir?) (split-path full-path)])
|
||||
base)
|
||||
resolved)
|
||||
resolved)])
|
||||
(if (string=? path orig-path)
|
||||
(error 'normalize-path "circular reference at ~s" path)
|
||||
(loop path))))))))]
|
||||
[resolve
|
||||
(lambda (path)
|
||||
(if (string=? path (resolve-path path))
|
||||
path
|
||||
(resolve-all path #f)))]
|
||||
[normalize-path
|
||||
(case-lambda
|
||||
[(orig-path) (do-normalize-path orig-path (current-directory))]
|
||||
[(orig-path wrt)
|
||||
(unless (complete-path? wrt)
|
||||
(raise-type-error 'normalize-path "complete path" wrt))
|
||||
(do-normalize-path orig-path wrt)])]
|
||||
[error-not-a-dir
|
||||
(lambda (path)
|
||||
(error 'normalize-path
|
||||
"~s (within the input path) is not a directory or does not exist"
|
||||
path))]
|
||||
[do-normalize-path
|
||||
(lambda (orig-path wrt)
|
||||
(let normalize ([path (expand-path orig-path)])
|
||||
(let-values ([(base name dir?) (split-path path)])
|
||||
(cond
|
||||
[(eq? name 'up)
|
||||
(let up ([base (if (eq? base 'relative)
|
||||
wrt
|
||||
(resolve-all base wrt))])
|
||||
(if (directory-exists? base)
|
||||
(let-values ([(prev name dir?) (split-path base)])
|
||||
(cond
|
||||
[(not prev)
|
||||
(error 'normalize-path
|
||||
"root has no parent directory: ~s"
|
||||
orig-path)]
|
||||
[else
|
||||
(let ([prev
|
||||
(if (eq? prev 'relative)
|
||||
wrt
|
||||
(normalize prev))])
|
||||
(cond
|
||||
[(eq? name 'same) (up prev)]
|
||||
[(eq? name 'up) (up (up prev))]
|
||||
[else prev]))]))
|
||||
(error-not-a-dir base)))]
|
||||
[(eq? name 'same)
|
||||
(cond
|
||||
[(eq? base 'relative) wrt]
|
||||
[else (let ([n (normalize base)])
|
||||
(if (directory-exists? n)
|
||||
n
|
||||
(error-not-a-dir n)))])]
|
||||
[else
|
||||
(cond
|
||||
[(not base) (path->complete-path path)]
|
||||
[else (let* ([base (if (eq? base 'relative)
|
||||
(normalize wrt)
|
||||
(normalize base))]
|
||||
[path (if (directory-exists? base)
|
||||
(build-path base name)
|
||||
(error-not-a-dir base))]
|
||||
[resolved (expand-path (resolve path))])
|
||||
(cond
|
||||
[(relative-path? resolved)
|
||||
(normalize (build-path base resolved))]
|
||||
[(complete-path? resolved)
|
||||
resolved]
|
||||
[else (path->complete-path resolved base)]))])]))))])
|
||||
normalize-path))
|
||||
|
||||
; Argument must be in normal form
|
||||
(define explode-path
|
||||
(lambda (orig-path)
|
||||
(let loop ([path orig-path][rest '()])
|
||||
(let-values ([(base name dir?) (split-path path)])
|
||||
(if (or (and base
|
||||
(not (string? base)))
|
||||
(not (string? name)))
|
||||
(error 'explode-path "input was not in normal form: ~s" orig-path))
|
||||
(if base
|
||||
(loop base (cons name rest))
|
||||
(cons name rest))))))
|
||||
|
||||
; Arguments must be in normal form
|
||||
(define find-relative-path
|
||||
(lambda (directory filename)
|
||||
(let ([dir (explode-path directory)]
|
||||
[file (explode-path filename)])
|
||||
(if (not (string=? (car dir) (car file)))
|
||||
filename
|
||||
(let loop ([dir (cdr dir)][file (cdr file)])
|
||||
(cond
|
||||
[(null? dir) (if (null? file) filename (apply build-path file))]
|
||||
[(null? file) (apply build-path (map (lambda (x) 'up) dir))]
|
||||
[(string=? (car dir) (car file))
|
||||
(loop (cdr dir) (cdr file))]
|
||||
[else
|
||||
(apply build-path
|
||||
(append (map (lambda (x) 'up) dir)
|
||||
file))]))))))
|
||||
|
||||
(define file-name-from-path
|
||||
(lambda (name)
|
||||
(let-values ([(base file dir?) (split-path name)])
|
||||
(if (and (not dir?) (string? file))
|
||||
file
|
||||
#f))))
|
||||
|
||||
(define path-only
|
||||
(lambda (name)
|
||||
(let-values ([(base file dir?) (split-path name)])
|
||||
(cond
|
||||
[dir? name]
|
||||
[(string? base) base]
|
||||
[else #f]))))
|
||||
|
||||
; name can be any string; we just look for a dot
|
||||
(define filename-extension
|
||||
(lambda (name)
|
||||
(let* ([len (string-length name)]
|
||||
[extension
|
||||
(let loop ([p (sub1 len)])
|
||||
(cond
|
||||
[(negative? p) #f]
|
||||
[(char=? (string-ref name p) #\.)
|
||||
(substring name (add1 p) len)]
|
||||
[else (loop (sub1 p))]))])
|
||||
(if extension
|
||||
(s:string-lowercase! extension))
|
||||
extension)))
|
||||
|
||||
|
||||
(define (delete-directory/files path)
|
||||
(cond
|
||||
[(or (link-exists? path) (file-exists? path))
|
||||
(unless (delete-file path)
|
||||
(error 'delete-directory/files
|
||||
"error deleting file or link: ~a" path))]
|
||||
[(directory-exists? path)
|
||||
(for-each (lambda (e) (delete-directory/files (build-path path e)))
|
||||
(directory-list path))
|
||||
(unless (delete-directory path)
|
||||
(error 'delete-directory/files
|
||||
"error deleting a directory: ~a" path))]
|
||||
[else (error 'delete-directory/files
|
||||
"encountered ~a, neither a file nor a directory"
|
||||
path)]))
|
||||
|
||||
(define (make-directory* dir)
|
||||
(let-values ([(base name dir?) (split-path dir)])
|
||||
(when (and (string? base)
|
||||
(not (directory-exists? base)))
|
||||
(make-directory* base))
|
||||
(make-directory dir)))
|
||||
|
||||
(define make-temporary-file
|
||||
(case-lambda
|
||||
[(template)
|
||||
(let ([tmpdir (find-system-path 'temp-dir)])
|
||||
(let loop ([s (current-seconds)][ms (current-milliseconds)])
|
||||
(let ([name (build-path tmpdir (format template (format "~a~a" s ms)))])
|
||||
(with-handlers ([exn:i/o:filesystem? (lambda (x)
|
||||
(if (file-exists? name)
|
||||
;; too slow
|
||||
(loop s (add1 ms))
|
||||
;; It's something else; give up
|
||||
(raise x)))])
|
||||
(close-output-port (open-output-file name))
|
||||
name))))]
|
||||
[() (make-temporary-file "mztmp~a")]))
|
||||
|
||||
(define find-library
|
||||
(case-lambda
|
||||
[(name) (find-library name "mzlib")]
|
||||
[(name collection . cp)
|
||||
(let ([dir (with-handlers ([void (lambda (exn) #f)])
|
||||
(apply collection-path collection cp))])
|
||||
(if dir
|
||||
(let ([file (build-path dir name)])
|
||||
(if (file-exists? file)
|
||||
file
|
||||
#f))
|
||||
#f))])))
|
||||
|
||||
18
collects/mzlib/files.ss
Normal file
18
collects/mzlib/files.ss
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
|
||||
(begin-elaboration-time
|
||||
(require-library "functios.ss")
|
||||
(require-library "strings.ss"))
|
||||
|
||||
(define-signature mzlib:file^
|
||||
(find-relative-path
|
||||
explode-path
|
||||
normalize-path
|
||||
build-absolute-path
|
||||
build-relative-path
|
||||
filename-extension
|
||||
file-name-from-path
|
||||
path-only
|
||||
delete-directory/files
|
||||
make-directory*
|
||||
make-temporary-file
|
||||
find-library))
|
||||
8
collects/mzlib/fileu.ss
Normal file
8
collects/mzlib/fileu.ss
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
|
||||
(require-library "files.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "refer.ss"))
|
||||
|
||||
(define mzlib:file@ (require-library-unit/sig "filer.ss"))
|
||||
|
||||
8
collects/mzlib/functio.ss
Normal file
8
collects/mzlib/functio.ss
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
|
||||
(require-library "functiou.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:function^
|
||||
mzlib:function@)
|
||||
2
collects/mzlib/function.ss
Normal file
2
collects/mzlib/function.ss
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(require-library "functio.ss")
|
||||
317
collects/mzlib/functior.ss
Normal file
317
collects/mzlib/functior.ss
Normal file
|
|
@ -0,0 +1,317 @@
|
|||
(unit/sig
|
||||
mzlib:function^
|
||||
(import)
|
||||
|
||||
(define true #t)
|
||||
(define false #f)
|
||||
|
||||
(define identity (polymorphic (lambda (x) x)))
|
||||
|
||||
(define compose
|
||||
(polymorphic
|
||||
(case-lambda
|
||||
[(f) (if (procedure? f) f (raise-type-error 'compose "procedure" f))]
|
||||
[(f g)
|
||||
(let ([f (compose f)]
|
||||
[g (compose g)])
|
||||
(if (eqv? 1 (arity f)) ; optimize: don't use call-w-values
|
||||
(if (eqv? 1 (arity g)) ; optimize: single arity everywhere
|
||||
(lambda (x) (f (g x)))
|
||||
(lambda args (f (apply g args))))
|
||||
(if (eqv? 1 (arity g)) ; optimize: single input
|
||||
(lambda (a)
|
||||
(call-with-values
|
||||
(lambda () (g a))
|
||||
f))
|
||||
(lambda args
|
||||
(call-with-values
|
||||
(lambda () (apply g args))
|
||||
f)))))]
|
||||
[(f . more)
|
||||
(let ([m (apply compose more)])
|
||||
(compose f m))])))
|
||||
|
||||
(define quicksort
|
||||
(polymorphic
|
||||
(lambda (l less-than)
|
||||
(let* ([v (list->vector l)]
|
||||
[count (vector-length v)])
|
||||
(let loop ([min 0][max count])
|
||||
(if (< min (sub1 max))
|
||||
(let ([pval (vector-ref v min)])
|
||||
(let pivot-loop ([pivot min]
|
||||
[pos (add1 min)])
|
||||
(if (< pos max)
|
||||
(let ([cval (vector-ref v pos)])
|
||||
(if (less-than cval pval)
|
||||
(begin
|
||||
(vector-set! v pos (vector-ref v pivot))
|
||||
(vector-set! v pivot cval)
|
||||
(pivot-loop (add1 pivot) (add1 pos)))
|
||||
(pivot-loop pivot (add1 pos))))
|
||||
(if (= min pivot)
|
||||
(loop (add1 pivot) max)
|
||||
(begin
|
||||
(loop min pivot)
|
||||
(loop pivot max))))))))
|
||||
(vector->list v)))))
|
||||
|
||||
(define ignore-errors
|
||||
(polymorphic
|
||||
(lambda (thunk)
|
||||
(let/ec escape
|
||||
(with-handlers ([void (lambda (x) (escape (void)))])
|
||||
(thunk))))))
|
||||
|
||||
(define remove
|
||||
(polymorphic
|
||||
(letrec ([rm (case-lambda
|
||||
[(item list) (rm item list equal?)]
|
||||
[(item list equal?)
|
||||
(let loop ([list list])
|
||||
(cond
|
||||
[(null? list) ()]
|
||||
[(equal? item (car list)) (cdr list)]
|
||||
[else (cons (car list)
|
||||
(loop (cdr list)))]))])])
|
||||
rm)))
|
||||
|
||||
(define remq
|
||||
(polymorphic
|
||||
(lambda (item list)
|
||||
(remove item list eq?))))
|
||||
|
||||
(define remv
|
||||
(polymorphic
|
||||
(lambda (item list)
|
||||
(remove item list eqv?))))
|
||||
|
||||
(define remove*
|
||||
(polymorphic
|
||||
(case-lambda
|
||||
[(l r equal?)
|
||||
(if (null? l)
|
||||
r
|
||||
(remove* (cdr l) (remove (car l) r equal?) equal?))]
|
||||
[(l r) (remove* l r equal?)])))
|
||||
|
||||
(define remq*
|
||||
(polymorphic
|
||||
(lambda (l r)
|
||||
(remove* l r eq?))))
|
||||
|
||||
(define remv*
|
||||
(polymorphic
|
||||
(lambda (l r)
|
||||
(remove* l r eqv?))))
|
||||
|
||||
;; fold : ((A B -> B) B (listof A) -> B)
|
||||
;; fold : ((A1 ... An B -> B) B (listof A1) ... (listof An) -> B)
|
||||
|
||||
;; foldl builds "B" from the beginning of the list to the end of the
|
||||
;; list and foldr builds the "B" from the end of the list to the
|
||||
;; beginning of the list.
|
||||
|
||||
(define mapadd
|
||||
(polymorphic
|
||||
(lambda (f l last)
|
||||
(letrec ((helper
|
||||
(lambda (l)
|
||||
(cond
|
||||
[(null? l) (list last)]
|
||||
[else (cons (f (car l)) (helper (cdr l)))]))))
|
||||
(helper l)))))
|
||||
|
||||
(define foldl
|
||||
(polymorphic
|
||||
(letrec ((fold-one
|
||||
(lambda (f init l)
|
||||
(letrec ((helper
|
||||
(lambda (init l)
|
||||
(cond
|
||||
[(null? l) init]
|
||||
[else (helper (f (car l) init) (cdr l))]))))
|
||||
(helper init l))))
|
||||
(fold-n
|
||||
(lambda (f init l)
|
||||
(cond
|
||||
[(ormap null? l)
|
||||
(if (andmap null? l)
|
||||
init
|
||||
(error 'foldl "received non-equal length input lists"))]
|
||||
[else (fold-n
|
||||
f
|
||||
(apply f (mapadd car l init))
|
||||
(map cdr l))]))))
|
||||
(case-lambda
|
||||
[(f init l) (fold-one f init l)]
|
||||
[(f init l . ls) (fold-n f init (cons l ls))]))))
|
||||
|
||||
(define foldr
|
||||
(polymorphic
|
||||
(letrec ((fold-one
|
||||
(lambda (f init l)
|
||||
(letrec ((helper
|
||||
(lambda (init l)
|
||||
(cond
|
||||
[(null? l) init]
|
||||
[else (f (car l) (helper init (cdr l)))]))))
|
||||
(helper init l))))
|
||||
(fold-n
|
||||
(lambda (f init l)
|
||||
(cond
|
||||
[(ormap null? l)
|
||||
(if (andmap null? l)
|
||||
init
|
||||
(error 'foldr "received non-equal length input lists"))]
|
||||
[else (apply f
|
||||
(mapadd car l
|
||||
(fold-n f init (map cdr l))))]))))
|
||||
(case-lambda
|
||||
[(f init l) (fold-one f init l)]
|
||||
[(f init l . ls) (fold-n f init (cons l ls))]))))
|
||||
|
||||
(define make-find
|
||||
(lambda (name whole-list?)
|
||||
(polymorphic
|
||||
(lambda (f list)
|
||||
(unless (and (procedure? f)
|
||||
(procedure-arity-includes? f 1))
|
||||
(raise-type-error name "procedure (arity 1)" f))
|
||||
(let loop ([l list])
|
||||
(cond
|
||||
[(null? l) #f]
|
||||
[(not (pair? l))
|
||||
(raise (make-exn:application:mismatch
|
||||
(format "~a: second argument must be a (proper) list; given ~e" name list)
|
||||
(current-continuation-marks)
|
||||
list))]
|
||||
[(f (car l)) (if whole-list? l (car l))]
|
||||
[else (loop (cdr l))]))))))
|
||||
|
||||
(define assf
|
||||
(make-find 'assf #f))
|
||||
|
||||
(define memf
|
||||
(make-find 'memf #t))
|
||||
|
||||
(define filter
|
||||
(polymorphic
|
||||
(lambda (f list)
|
||||
(unless (and (procedure? f)
|
||||
(procedure-arity-includes? f 1))
|
||||
(raise-type-error 'filter "procedure (arity 1)" f))
|
||||
(let loop ([l list])
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[(pair? l)
|
||||
(let* ([keep? (f (car l))]
|
||||
[frest (loop (cdr l))])
|
||||
(if keep?
|
||||
(cons (car l) frest)
|
||||
frest))]
|
||||
[else (raise (make-exn:application:mismatch
|
||||
(format "filter: second argument must be a (proper) list; given ~e" list)
|
||||
(current-continuation-marks)
|
||||
list))])))))
|
||||
|
||||
(define first (polymorphic (lambda (x)
|
||||
(unless (pair? x)
|
||||
(raise-type-error 'first "non-empty list" x))
|
||||
(car x))))
|
||||
(define second (polymorphic cadr))
|
||||
(define third (polymorphic caddr))
|
||||
(define fourth (polymorphic cadddr))
|
||||
(define fifth (polymorphic (compose fourth cdr)))
|
||||
(define sixth (polymorphic (compose fourth cddr)))
|
||||
(define seventh (polymorphic (compose fourth cdddr)))
|
||||
(define eighth (polymorphic (compose fourth cddddr)))
|
||||
|
||||
(define rest (polymorphic (lambda (x)
|
||||
(unless (pair? x)
|
||||
(raise-type-error 'rest "non-empty list" x))
|
||||
(cdr x))))
|
||||
|
||||
(define build-string
|
||||
(lambda (n fcn)
|
||||
(unless (and (integer? n) (exact? n) (>= n 0))
|
||||
(error 'build-string "~s must be an exact integer >= 0" n))
|
||||
(unless (procedure? fcn)
|
||||
(error 'build-string "~s must be a procedure" fcn))
|
||||
(let ((str (make-string n)))
|
||||
(let loop ((i 0))
|
||||
(if (= i n)
|
||||
str
|
||||
(begin
|
||||
(string-set! str i (fcn i))
|
||||
(loop (add1 i))))))))
|
||||
|
||||
;; (build-vector n f) returns a vector 0..n-1 where the ith element is (f i).
|
||||
;; The eval order is guaranteed to be: 0, 1, 2, ..., n-1.
|
||||
;; eg: (build-vector 4 (lambda (i) i)) ==> #4(0 1 2 3)
|
||||
|
||||
(define build-vector
|
||||
(polymorphic
|
||||
(lambda (n fcn)
|
||||
(unless (and (integer? n) (exact? n) (>= n 0))
|
||||
(error 'build-vector "~s must be an exact integer >= 0" n))
|
||||
(unless (procedure? fcn)
|
||||
(error 'build-vector "~s must be a procedure" fcn))
|
||||
(let ((vec (make-vector n)))
|
||||
(let loop ((i 0))
|
||||
(if (= i n) vec
|
||||
(begin
|
||||
(vector-set! vec i (fcn i))
|
||||
(loop (add1 i)))))))))
|
||||
|
||||
(define build-list
|
||||
(polymorphic
|
||||
(lambda (n fcn)
|
||||
(unless (and (integer? n) (exact? n) (>= n 0))
|
||||
(error 'build-list "~s must be an exact integer >= 0" n))
|
||||
(unless (procedure? fcn)
|
||||
(error 'build-list "~s must be a procedure" fcn))
|
||||
(if (zero? n) '()
|
||||
(let ([head (list (fcn 0))])
|
||||
(let loop ([i 1] [p head])
|
||||
(if (= i n) head
|
||||
(begin
|
||||
(set-cdr! p (list (fcn i)))
|
||||
(loop (add1 i) (cdr p))))))))))
|
||||
|
||||
(define loop-until
|
||||
(polymorphic
|
||||
(lambda (start done? next body)
|
||||
(let loop ([i start])
|
||||
(unless (done? i)
|
||||
(body i)
|
||||
(loop (next i)))))))
|
||||
|
||||
(define last-pair
|
||||
(polymorphic
|
||||
(lambda (l)
|
||||
(if (pair? l)
|
||||
(if (pair? (cdr l))
|
||||
(last-pair (cdr l))
|
||||
l)
|
||||
(raise-type-error 'last-pair "pair" l)))))
|
||||
|
||||
(define boolean=?
|
||||
(lambda (x y)
|
||||
(unless (and (boolean? x)
|
||||
(boolean? y))
|
||||
(raise-type-error 'boolean=?
|
||||
"boolean"
|
||||
(if (boolean? x) y x)))
|
||||
(eq? x y)))
|
||||
|
||||
(define (symbol=? x y)
|
||||
(unless (and (symbol? x)
|
||||
(symbol? y))
|
||||
(raise-type-error 'symbol=? "symbol"
|
||||
(if (symbol? x) y x)))
|
||||
(eq? x y))
|
||||
|
||||
(define cons? (lambda (x) (pair? x)))
|
||||
(define empty? (lambda (x) (null? x)))
|
||||
(define empty '()))
|
||||
54
collects/mzlib/functios.ss
Normal file
54
collects/mzlib/functios.ss
Normal file
|
|
@ -0,0 +1,54 @@
|
|||
|
||||
(begin-elaboration-time
|
||||
(require-relative-library "spidey.ss"))
|
||||
|
||||
(define-signature mzlib:function^
|
||||
(true
|
||||
false
|
||||
|
||||
first
|
||||
second
|
||||
third
|
||||
fourth
|
||||
fifth
|
||||
sixth
|
||||
seventh
|
||||
eighth
|
||||
|
||||
rest
|
||||
|
||||
cons?
|
||||
empty
|
||||
empty?
|
||||
|
||||
boolean=?
|
||||
symbol=?
|
||||
|
||||
identity
|
||||
compose
|
||||
foldl
|
||||
foldr
|
||||
|
||||
last-pair
|
||||
|
||||
remv
|
||||
remq
|
||||
remove
|
||||
remv*
|
||||
remq*
|
||||
remove*
|
||||
|
||||
assf
|
||||
memf
|
||||
|
||||
filter
|
||||
|
||||
build-string
|
||||
build-vector
|
||||
build-list
|
||||
|
||||
quicksort
|
||||
|
||||
loop-until
|
||||
|
||||
ignore-errors))
|
||||
8
collects/mzlib/functiou.ss
Normal file
8
collects/mzlib/functiou.ss
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
|
||||
(require-library "functios.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "refer.ss"))
|
||||
|
||||
(define mzlib:function@ (require-library-unit/sig "functior.ss"))
|
||||
|
||||
11
collects/mzlib/inflate.ss
Normal file
11
collects/mzlib/inflate.ss
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
|
||||
|
||||
(require-library "inflateu.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:inflate^
|
||||
mzlib:inflate@)
|
||||
|
||||
|
||||
888
collects/mzlib/inflater.ss
Normal file
888
collects/mzlib/inflater.ss
Normal file
|
|
@ -0,0 +1,888 @@
|
|||
|
||||
(unit/sig mzlib:inflate^
|
||||
(import)
|
||||
#|
|
||||
|
||||
/* inflate.c -- Not copyrighted 1992 by Mark Adler
|
||||
version c10p1, 10 January 1993 */
|
||||
; Taken from the gzip source distribution
|
||||
; Translated directly from C (obviously) by Matthew, April 1997
|
||||
|
||||
/* You can do whatever you like with this source file, though I would
|
||||
prefer that if you modify it and redistribute it that you include
|
||||
comments to that effect with your name and the date. Thank you.
|
||||
[The history has been moved to the file ChangeLog.]
|
||||
; ChangeLog is distributed with the gzip source.
|
||||
*/
|
||||
|
||||
/*
|
||||
Inflate deflated (PKZIP's method 8 compressed) data. The compression
|
||||
method searches for as much of the current string of bytes (up to a
|
||||
length of 258) in the previous 32K bytes. If it doesn't find any
|
||||
matches (of at least length 3), it codes the next byte. Otherwise, it
|
||||
codes the length of the matched string and its distance backwards from
|
||||
the current position. There is a single Huffman code that codes both
|
||||
single bytes (called "literals") and match lengths. A second Huffman
|
||||
code codes the distance information, which follows a length code. Each
|
||||
length or distance code actually represents a base value and a number
|
||||
of "extra" (sometimes zero) bits to get to add to the base value. At
|
||||
the end of each deflated block is a special end-of-block (EOB) literal/
|
||||
length code. The decoding process is basically: get a literal/length
|
||||
code; if EOB then done; if a literal, emit the decoded byte; if a
|
||||
length then get the distance and emit the referred-to bytes from the
|
||||
sliding window of previously emitted data.
|
||||
|
||||
There are (currently) three kinds of inflate blocks: stored, fixed, and
|
||||
dynamic. The compressor deals with some chunk of data at a time, and
|
||||
decides which method to use on a chunk-by-chunk basis. A chunk might
|
||||
typically be 32K or 64K. If the chunk is uncompressible, then the
|
||||
"stored" method is used. In this case, the bytes are simply stored as
|
||||
is, eight bits per byte, with none of the above coding. The bytes are
|
||||
preceded by a count, since there is no longer an EOB code.
|
||||
|
||||
If the data is compressible, then either the fixed or dynamic methods
|
||||
are used. In the dynamic method, the compressed data is preceded by
|
||||
an encoding of the literal/length and distance Huffman codes that are
|
||||
to be used to decode this block. The representation is itself Huffman
|
||||
coded, and so is preceded by a description of that code. These code
|
||||
descriptions take up a little space, and so for small blocks, there is
|
||||
a predefined set of codes, called the fixed codes. The fixed method is
|
||||
used if the block codes up smaller that way (usually for quite small
|
||||
chunks), otherwise the dynamic method is used. In the latter case, the
|
||||
codes are customized to the probabilities in the current block, and so
|
||||
can code it much better than the pre-determined fixed codes.
|
||||
|
||||
The Huffman codes themselves are decoded using a mutli-level table
|
||||
lookup, in order to maximize the speed of decoding plus the speed of
|
||||
building the decoding tables. See the comments below that precede the
|
||||
lbits and dbits tuning parameters.
|
||||
*/
|
||||
|
||||
|
||||
/*
|
||||
Notes beyond the 1.93a appnote.txt:
|
||||
|
||||
1. Distance pointers never point before the beginning of the output
|
||||
stream.
|
||||
2. Distance pointers can point back across blocks, up to 32k away.
|
||||
3. There is an implied maximum of 7 bits for the bit length table and
|
||||
15 bits for the actual data.
|
||||
4. If only one code exists, then it is encoded using one bit. (Zero
|
||||
would be more efficient, but perhaps a little confusing.) If two
|
||||
codes exist, they are coded using one bit each (0 and 1).
|
||||
5. There is no way of sending zero distance codes--a dummy must be
|
||||
sent if there are none. (History: a pre 2.0 version of PKZIP would
|
||||
store blocks with no distance codes, but this was discovered to be
|
||||
too harsh a criterion.) Valid only for 1.93a. 2.04c does allow
|
||||
zero distance codes, which is sent as one code of zero bits in
|
||||
length.
|
||||
6. There are up to 286 literal/length codes. Code 256 represents the
|
||||
end-of-block. Note however that the static length tree defines
|
||||
288 codes just to fill out the Huffman codes. Codes 286 and 287
|
||||
cannot be used though, since there is no length base or extra bits
|
||||
defined for them. Similarly, there are up to 30 distance codes.
|
||||
However, static trees define 32 codes (all 5 bits) to fill out the
|
||||
Huffman codes, but the last two had better not show up in the data.
|
||||
7. Unzip can check dynamic Huffman blocks for complete code sets.
|
||||
The exception is that a single code would not be complete (see #4).
|
||||
8. The five bits following the block type is really the number of
|
||||
literal codes sent minus 257.
|
||||
9. Length codes 8,16,16 are interpreted as 13 length codes of 8 bits
|
||||
(1+6+6). Therefore, to output three times the length, you output
|
||||
three codes (1+1+1), whereas to output four times the same length,
|
||||
you only need two codes (1+3). Hmm.
|
||||
10. In the tree reconstruction algorithm, Code = Code + Increment
|
||||
only if BitLength(i) is not zero. (Pretty obvious.)
|
||||
11. Correction: 4 Bits: # of Bit Length codes - 4 (4 - 19)
|
||||
12. Note: length code 284 can represent 227-258, but length code 285
|
||||
really is 258. The last length deserves its own, short code
|
||||
since it gets used a lot in very redundant files. The length
|
||||
258 is special since 258 - 3 (the min match length) is 255.
|
||||
13. The literal/length and distance code bit lengths are read as a
|
||||
single stream of lengths. It is possible (and advantageous) for
|
||||
a repeat code (16, 17, or 18) to go across the boundary between
|
||||
the two sets of lengths.
|
||||
*/
|
||||
|
||||
|#
|
||||
|
||||
#|
|
||||
/* Huffman code lookup table entry--this entry is four bytes for machines
|
||||
that have 16-bit pointers (e.g. PC's in the small or medium model).
|
||||
Valid extra bits are 0..13. e == 15 is EOB (end of block), e == 16
|
||||
means that v is a literal, 16 < e < 32 means that v is a pointer to
|
||||
the next table, which codes e - 16 bits, and lastly e == 99 indicates
|
||||
an unused code. If a code with e == 99 is looked up, this implies an
|
||||
error in the data. */
|
||||
|#
|
||||
|
||||
(define-struct huft (e b v))
|
||||
|
||||
(define (huft-copy dest src)
|
||||
(set-huft-e! dest (huft-e src))
|
||||
(set-huft-b! dest (huft-b src))
|
||||
(set-huft-v! dest (huft-v src)))
|
||||
|
||||
(define (step start < end add1 f)
|
||||
(let loop ([i start])
|
||||
(when (< i end)
|
||||
(f i)
|
||||
(loop (add1 i)))))
|
||||
|
||||
(define (subvector v offset)
|
||||
(let* ([len (- (vector-length v) offset)]
|
||||
[new (make-vector len)])
|
||||
(step 0 < len add1
|
||||
(lambda (i)
|
||||
(vector-set! new i (vector-ref v (+ i offset)))))
|
||||
new))
|
||||
|
||||
(define (build-vector n p)
|
||||
(let ([v (make-vector n)])
|
||||
(step 0 < n add1 (lambda (i) (vector-set! v i (p i))))
|
||||
v))
|
||||
|
||||
#|
|
||||
/* The inflate algorithm uses a sliding 32K byte window on the uncompressed
|
||||
stream to find repeated byte strings. This is implemented here as a
|
||||
circular buffer. The index is updated simply by incrementing and then
|
||||
and'ing with 0x7fff (32K-1). */
|
||||
|#
|
||||
|
||||
(define WSIZE 32768)
|
||||
|
||||
(define border
|
||||
(vector
|
||||
16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15))
|
||||
|
||||
(define cplens
|
||||
(vector
|
||||
3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31
|
||||
35 43 51 59 67 83 99 115 131 163 195 227 258 0 0))
|
||||
; /* note: see note #13 above about the 258 in this list. */
|
||||
(define cplext
|
||||
(vector
|
||||
0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2
|
||||
3 3 3 3 4 4 4 4 5 5 5 5 0 99 99)) ; /* 99==invalid */
|
||||
(define cpdist
|
||||
(vector
|
||||
1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193
|
||||
257 385 513 769 1025 1537 2049 3073 4097 6145
|
||||
8193 12289 16385 24577))
|
||||
(define cpdext
|
||||
(vector
|
||||
0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6
|
||||
7 7 8 8 9 9 10 10 11 11
|
||||
12 12 13 13))
|
||||
|
||||
(define mask_bits
|
||||
(vector
|
||||
#x0000
|
||||
#x0001 #x0003 #x0007 #x000f #x001f #x003f #x007f #x00ff
|
||||
#x01ff #x03ff #x07ff #x0fff #x1fff #x3fff #x7fff #xffff))
|
||||
|
||||
(define lbits 9) ; /* bits in base literal/length lookup table */
|
||||
(define dbits 6) ; /* bits in base distance lookup table */
|
||||
|
||||
|
||||
; /* If BMAX needs to be larger than 16, then h and x[] should be ulg. */
|
||||
(define BMAX 16) ; /* maximum bit length of any code (16 for explode) */
|
||||
(define N_MAX 288) ; /* maximum number of codes in any set */
|
||||
|
||||
(define (inflate input-port output-port)
|
||||
|
||||
(define slide (make-string WSIZE))
|
||||
(define wp 0)
|
||||
|
||||
(define (flush-output len)
|
||||
; write out the data
|
||||
(if (= len WSIZE)
|
||||
(display slide output-port)
|
||||
(display (substring slide 0 len) output-port)))
|
||||
|
||||
(define (check-flush)
|
||||
(when (= wp WSIZE)
|
||||
(flush-output WSIZE)
|
||||
(set! wp 0)))
|
||||
|
||||
#|
|
||||
/* Macros for inflate() bit peeking and grabbing.
|
||||
The usage is:
|
||||
|
||||
NEEDBITS(j)
|
||||
x = b & mask_bits[j];
|
||||
DUMPBITS(j)
|
||||
|
||||
where NEEDBITS makes sure that b has at least j bits in it, and
|
||||
DUMPBITS removes the bits from b. The macros use the variable k
|
||||
for the number of bits in b. Normally, b and k are register
|
||||
variables for speed, and are initialized at the beginning of a
|
||||
routine that uses these macros from a global bit buffer and count.
|
||||
|
||||
If we assume that EOB will be the longest code, then we will never
|
||||
ask for bits with NEEDBITS that are beyond the end of the stream.
|
||||
So, NEEDBITS should not read any more bytes than are needed to
|
||||
meet the request. Then no bytes need to be "returned" to the buffer
|
||||
at the end of the last block.
|
||||
|
||||
However, this assumption is not true for fixed blocks--the EOB code
|
||||
is 7 bits, but the other literal/length codes can be 8 or 9 bits.
|
||||
(The EOB code is shorter than other codes because fixed blocks are
|
||||
generally short. So, while a block always has an EOB, many other
|
||||
literal/length codes have a significantly lower probability of
|
||||
showing up at all.) However, by making the first table have a
|
||||
lookup of seven bits, the EOB code will be found in that first
|
||||
lookup, and so will not require that too many bits be pulled from
|
||||
the stream.
|
||||
*/
|
||||
|#
|
||||
|
||||
(define bb 0) ; /* bit buffer */
|
||||
(define bk 0) ; /* bits in bit buffer */
|
||||
|
||||
(define (NEEDBITS n)
|
||||
(when (< bk n)
|
||||
(set! bb (+ bb (arithmetic-shift (char->integer (read-char input-port)) bk)))
|
||||
(set! bk (+ bk 8))
|
||||
(NEEDBITS n)))
|
||||
(define (DUMPBITS n)
|
||||
(set! bb (arithmetic-shift bb (- n)))
|
||||
(set! bk (- bk n)))
|
||||
|
||||
(define (GETBITS n)
|
||||
(NEEDBITS n)
|
||||
(begin0
|
||||
bb
|
||||
(DUMPBITS n)))
|
||||
|
||||
#|
|
||||
/*
|
||||
Huffman code decoding is performed using a multi-level table lookup.
|
||||
The fastest way to decode is to simply build a lookup table whose
|
||||
size is determined by the longest code. However, the time it takes
|
||||
to build this table can also be a factor if the data being decoded
|
||||
is not very long. The most common codes are necessarily the
|
||||
shortest codes, so those codes dominate the decoding time, and hence
|
||||
the speed. The idea is you can have a shorter table that decodes the
|
||||
shorter, more probable codes, and then point to subsidiary tables for
|
||||
the longer codes. The time it costs to decode the longer codes is
|
||||
then traded against the time it takes to make longer tables.
|
||||
|
||||
This results of this trade are in the variables lbits and dbits
|
||||
below. lbits is the number of bits the first level table for literal/
|
||||
length codes can decode in one step, and dbits is the same thing for
|
||||
the distance codes. Subsequent tables are also less than or equal to
|
||||
those sizes. These values may be adjusted either when all of the
|
||||
codes are shorter than that, in which case the longest code length in
|
||||
bits is used, or when the shortest code is *longer* than the requested
|
||||
table size, in which case the length of the shortest code in bits is
|
||||
used.
|
||||
|
||||
There are two different values for the two tables, since they code a
|
||||
different number of possibilities each. The literal/length table
|
||||
codes 286 possible values, or in a flat code, a little over eight
|
||||
bits. The distance table codes 30 possible values, or a little less
|
||||
than five bits, flat. The optimum values for speed end up being
|
||||
about one bit more than those, so lbits is 8+1 and dbits is 5+1.
|
||||
The optimum values may differ though from machine to machine, and
|
||||
possibly even between compilers. Your mileage may vary.
|
||||
*/
|
||||
|#
|
||||
|
||||
(define (huft_build
|
||||
b ; int vector /* code lengths in bits (all assumed <= BMAX) */
|
||||
n ; /* number of codes (assumed <= N_MAX) */
|
||||
s ; /* number of simple-valued codes (0..s-1) */
|
||||
d ; int vector /* list of base values for non-simple codes */
|
||||
e ; int vector /* list of extra bits for non-simple codes */
|
||||
m ; int /* maximum lookup bits, returns actual */
|
||||
incomp-ok?)
|
||||
; return: new-t new-m ok?
|
||||
|
||||
#|
|
||||
/* Given a list of code lengths and a maximum table size, make a set of
|
||||
tables to decode that set of codes. Return zero on success, one if
|
||||
the given code set is incomplete (the tables are still built in this
|
||||
case), two if the input is invalid (all zero length codes or an
|
||||
oversubscribed set of lengths), and three if not enough memory. */
|
||||
|#
|
||||
(define c (make-vector (add1 BMAX) 0))
|
||||
(define x (make-vector (add1 BMAX)))
|
||||
(define v (make-vector N_MAX))
|
||||
|
||||
(define final-y 0)
|
||||
(define t-result #f)
|
||||
|
||||
; (printf "n: ~s~n" n)
|
||||
|
||||
(let/ec return
|
||||
|
||||
#|
|
||||
(if (= n 270)
|
||||
(step 0 < n add1
|
||||
(lambda (i) (printf "b[~a] = ~a~n" i (vector-ref b i)))))
|
||||
|#
|
||||
|
||||
(step 0 < n add1
|
||||
(lambda (i)
|
||||
(let ([pos (vector-ref b i)])
|
||||
(vector-set! c pos (add1 (vector-ref c pos))))))
|
||||
|
||||
(when (= n (vector-ref c 0))
|
||||
; (printf "zero~n")
|
||||
(return #f 0 #t))
|
||||
|
||||
#|
|
||||
(when (= n 270)
|
||||
(step 0 <= BMAX add1
|
||||
(lambda (i)
|
||||
(printf "c[~s]: ~s~n" i (vector-ref c i)))))
|
||||
|#
|
||||
|
||||
; /* Find minimum and maximum length, bound m-result by those */
|
||||
(let* ([j ; min-code-length
|
||||
(let loop ([j 1])
|
||||
(cond
|
||||
[(> j BMAX) j]
|
||||
[(positive? (vector-ref c j)) j]
|
||||
[else (loop (add1 j))]))]
|
||||
[k j]
|
||||
[i ; max-code-length
|
||||
(let loop ([i BMAX])
|
||||
(cond
|
||||
[(zero? i) 0]
|
||||
[(positive? (vector-ref c i)) i]
|
||||
[else (loop (sub1 i))]))]
|
||||
[g i]
|
||||
[l (min (max m j) i)]
|
||||
[m-result l])
|
||||
; (printf "min: ~s max: ~s~n" k g)
|
||||
; /* Adjust last length count to fill out codes, if needed */
|
||||
(let-values ([(y j)
|
||||
(let loop ([y (arithmetic-shift 1 j)][j j])
|
||||
(if (>= j i)
|
||||
(values y j)
|
||||
(let ([new-y (- y (vector-ref c j))])
|
||||
(if (negative? new-y)
|
||||
(begin
|
||||
(error 'inflate
|
||||
"bad input: more codes than bits")
|
||||
(return null m-result #f))
|
||||
(loop (* new-y 2) (add1 j))))))])
|
||||
; (printf "loop y: ~s~n" y)
|
||||
(let ([y (- y (vector-ref c i))])
|
||||
(when (negative? y)
|
||||
(error 'inflate "bad input: more codes than bits")
|
||||
(return #f m-result #f))
|
||||
; (printf "set c[~s] ~s + ~s~n" i (vector-ref c i) y)
|
||||
(vector-set! c i (+ (vector-ref c i) y))
|
||||
(set! final-y y)))
|
||||
; /* Generate starting offsets into the value table for each length */
|
||||
(vector-set! x 1 0)
|
||||
(let* ([j (let loop ([i (sub1 i)][x-pos 2][c-pos 1][j 0])
|
||||
(if (zero? i)
|
||||
j
|
||||
(let ([v (vector-ref c c-pos)])
|
||||
(vector-set! x x-pos (+ j v))
|
||||
(loop (sub1 i) (add1 x-pos) (add1 c-pos) (+ j v)))))])
|
||||
; /* Make a table of values in order of bit lengths */
|
||||
(let loop ([i 0][b-pos 0])
|
||||
(let ([j (vector-ref b b-pos)])
|
||||
(unless (zero? j)
|
||||
(let ([xj (vector-ref x j)])
|
||||
(vector-set! x j (add1 xj))
|
||||
(vector-set! v xj i)))
|
||||
(let ([new-i (add1 i)])
|
||||
(when (< new-i n)
|
||||
(loop new-i (add1 b-pos))))))
|
||||
|
||||
; /* Generate the Huffman codes and for each, make the table entries */
|
||||
(vector-set! x 0 0) ; /* first Huffman code is zero */
|
||||
(let ([v-pos 0] ; /* grab values in bit order */
|
||||
[i 0] ; /* the Huffman code of length k bits for value *p */
|
||||
[h -1] ; /* no tables yet--level -1 */
|
||||
[w (- l)] ; /* bits decoded == (l * h) */
|
||||
[u (make-vector BMAX)] ; /* table stack */
|
||||
[q null] ; /* points to current table */
|
||||
[z 0] ; /* number of entries in current table */
|
||||
[r (make-huft 0 0 0)]) ; /* table entry for structure assignment */
|
||||
; /* go through the bit lengths (k already is bits in shortest code) */
|
||||
(let k-loop ([k k])
|
||||
; (printf "k: ~s~n" k)
|
||||
(when (<= k g)
|
||||
(let ([a (vector-ref c k)])
|
||||
(let a-loop ([a (sub1 a)])
|
||||
(unless (negative? a)
|
||||
; (printf "a: ~s~n" a)
|
||||
; /* here i is the Huffman code of length k bits for value *p */
|
||||
; /* make tables up to required level */
|
||||
(let kwl-loop ()
|
||||
(when (> k (+ w l))
|
||||
(set! h (add1 h))
|
||||
(set! w (+ w l)) ; /* previous table always l bits */
|
||||
|
||||
; /* compute minimum size table less than or equal to l bits */
|
||||
(set! z (min (- g w) l)) ; /* upper limit on table size */
|
||||
|
||||
; (printf "z: ~s k: ~s w: ~s~n" z k w)
|
||||
|
||||
(let* ([j (- k w)]
|
||||
[f (arithmetic-shift 1 j)])
|
||||
(when (> f (add1 a)) ; /* try a k-w bit table */
|
||||
; /* too few codes for k-w bit table */
|
||||
(set! f (- f a 1)) ; /* deduct codes from patterns left */
|
||||
; /* try smaller tables up to z bits */
|
||||
(let loop ([c-pos k])
|
||||
(set! j (add1 j))
|
||||
(when (< j z)
|
||||
(set! f (* f 2))
|
||||
(let* ([c-pos (add1 c-pos)]
|
||||
[cv (vector-ref c c-pos)])
|
||||
(if (<= f cv)
|
||||
(void) ; /* enough codes to use up j bits */
|
||||
(begin
|
||||
(set! f (- f cv)) ; /* else deduct codes from patterns */
|
||||
(loop c-pos)))))))
|
||||
(set! z (arithmetic-shift 1 j)) ; /* table entries for j-bit table */
|
||||
|
||||
; /* allocate and link in new table */
|
||||
; (printf "alloc: ~a~n" z)
|
||||
(set! q (build-vector z (lambda (i) (make-huft 0 0 0))))
|
||||
|
||||
(when (not t-result)
|
||||
(set! t-result q))
|
||||
|
||||
(vector-set! u h q)
|
||||
|
||||
; /* connect to last table, if there is one */
|
||||
(unless (zero? h)
|
||||
(vector-set! x h i) ; /* save pattern for backing up */
|
||||
(set-huft-b! r l) ; /* bits to dump before this table */
|
||||
(set-huft-e! r (+ j 16)); /* bits in this table */
|
||||
(set-huft-v! r q) ; /* pointer to this table */
|
||||
(set! j (arithmetic-shift i (- l w)))
|
||||
; /* connect to last table: */
|
||||
(huft-copy (vector-ref (vector-ref u (sub1 h)) j) r)))
|
||||
|
||||
(kwl-loop)))
|
||||
|
||||
(set-huft-b! r (- k w)) ; cast uch (- k w) if needed
|
||||
(if (>= v-pos n)
|
||||
(set-huft-e! r 99) ; /* out of values--invalid code */
|
||||
(let ([vv (vector-ref v v-pos)])
|
||||
; (printf "*p: ~s s: ~s~n" vv s)
|
||||
(if (< vv s)
|
||||
(begin
|
||||
(set-huft-e! r (if (< vv 256) 16 15)) ; /* 256 is end-of-block code */
|
||||
(set-huft-v! r vv)) ; /* simple code is just the value */
|
||||
(begin
|
||||
(set-huft-e! r (vector-ref e (- vv s))) ; /* non-simple--look up in lists */
|
||||
(set-huft-v! r (vector-ref d (- vv s)))))
|
||||
(set! v-pos (add1 v-pos))))
|
||||
; /* fill code-like entries with r */
|
||||
; (printf "i: ~s w: ~s k: ~s~n" i w k)
|
||||
(let ([f (arithmetic-shift 1 (- k w))]) ; /* i repeats in table every f entries */
|
||||
(let loop ([j (arithmetic-shift i (- w))])
|
||||
(when (< j z)
|
||||
(huft-copy (vector-ref q j) r)
|
||||
(loop (+ j f)))))
|
||||
; /* backwards increment the k-bit code i */
|
||||
(let loop ([j (arithmetic-shift 1 (sub1 k))])
|
||||
(if (positive? (bitwise-and i j))
|
||||
(begin
|
||||
(set! i (bitwise-xor i j))
|
||||
(loop (arithmetic-shift j -1)))
|
||||
(set! i (bitwise-xor i j))))
|
||||
; /* backup over finished tables */
|
||||
(let loop ()
|
||||
(unless (= (vector-ref x h) (bitwise-and i (sub1 (arithmetic-shift 1 w))))
|
||||
(set! h (sub1 h)) ; /* don't need to update q */
|
||||
(set! w (- w l))
|
||||
(loop)))
|
||||
|
||||
(a-loop (sub1 a))))
|
||||
(k-loop (add1 k)))))
|
||||
|
||||
; /* Return #f as third if we were given an incomplete table */
|
||||
; (printf "done: ~s ~s~n" final-y g)
|
||||
(let ([ok? (or incomp-ok?
|
||||
(not (and (not (zero? final-y))
|
||||
(not (= g 1)))))])
|
||||
(unless ok?
|
||||
(error 'inflate "incomplete table"))
|
||||
(values t-result m-result ok?)))))))
|
||||
|
||||
(define (inflate_codes
|
||||
tl ; vector of hufts ; /* literal/length tables */
|
||||
td ; vector of hufts ; /* distance decoder tables */
|
||||
bl ; /* number of bits decoded by tl */
|
||||
bd) ; /* number of bits decoded by td[] */
|
||||
; /* inflate (decompress) the codes in a deflated (compressed) block.
|
||||
; Return an error code or zero if it all goes ok. */
|
||||
|
||||
; /* inflate the coded data */
|
||||
|
||||
; /* precompute masks for speed */
|
||||
(define ml (vector-ref mask_bits bl))
|
||||
(define md (vector-ref mask_bits bd))
|
||||
(define t (void))
|
||||
(define e 0)
|
||||
(define n 0)
|
||||
(define d 0)
|
||||
|
||||
(let/ec return
|
||||
|
||||
(define (jump-to-next)
|
||||
(let loop ()
|
||||
(when (= e 99)
|
||||
(error 'inflate "bad inflate code")
|
||||
(return #f))
|
||||
(DUMPBITS (huft-b t))
|
||||
(set! e (- e 16))
|
||||
(NEEDBITS e)
|
||||
(set! t (vector-ref (huft-v t) (bitwise-and bb (vector-ref mask_bits e))))
|
||||
(set! e (huft-e t))
|
||||
(when (> e 16)
|
||||
(loop))))
|
||||
|
||||
(let loop () ; /* do until end of block */
|
||||
(NEEDBITS bl)
|
||||
(set! t (vector-ref tl (bitwise-and bb ml)))
|
||||
; (printf "t->e: ~s t->b: ~s~n" (huft-e t) (huft-b t))
|
||||
(set! e (huft-e t))
|
||||
(if (> e 16)
|
||||
(jump-to-next))
|
||||
(DUMPBITS (huft-b t))
|
||||
; (printf "e: ~s~n" e)
|
||||
(if (= e 16) ; /* then it's a literal */
|
||||
(begin
|
||||
(string-set! slide wp (integer->char (huft-v t)))
|
||||
(set! wp (add1 wp))
|
||||
(check-flush))
|
||||
(begin ; /* it's an EOB or a length */
|
||||
; /* exit if end of block */
|
||||
(when (= e 15)
|
||||
(return #t))
|
||||
|
||||
; /* get length of block to copy */
|
||||
(NEEDBITS e)
|
||||
(set! n (+ (huft-v t) (bitwise-and bb (vector-ref mask_bits e))))
|
||||
(DUMPBITS e)
|
||||
; (printf "n: ~s bb: ~s md: ~s~n" n bb md)
|
||||
|
||||
; /* decode distance of block to copy */
|
||||
(NEEDBITS bd)
|
||||
(set! t (vector-ref td (bitwise-and bb md)))
|
||||
; (printf "t->e: ~s t->b: ~s~n" (huft-e t) (huft-b t))
|
||||
(set! e (huft-e t))
|
||||
; (printf "e: ~s~n" e)
|
||||
(when (> e 16)
|
||||
(jump-to-next))
|
||||
(DUMPBITS (huft-b t))
|
||||
; (printf "e: ~s~n" e)
|
||||
|
||||
(NEEDBITS e)
|
||||
(set! d (modulo (- wp (huft-v t) (bitwise-and bb (vector-ref mask_bits e))) WSIZE))
|
||||
(DUMPBITS e)
|
||||
|
||||
; (printf "wp: ~s t->v: ~s d: ~s~n" wp (huft-v t) d)
|
||||
|
||||
; /* do the copy */
|
||||
(let loop ()
|
||||
(set! d (bitwise-and d (sub1 WSIZE)))
|
||||
(set! e (min n (- WSIZE (max d wp))))
|
||||
(set! n (- n e))
|
||||
(let loop ()
|
||||
(string-set! slide wp (string-ref slide d))
|
||||
(set! wp (add1 wp))
|
||||
(set! d (add1 d))
|
||||
(set! e (sub1 e))
|
||||
(unless (zero? e)
|
||||
(loop)))
|
||||
(check-flush)
|
||||
(unless (zero? n)
|
||||
(loop)))))
|
||||
(loop))))
|
||||
|
||||
(define (inflate_stored)
|
||||
; /* "decompress" an inflated type 0 (stored) block. */
|
||||
|
||||
(let/ec return
|
||||
|
||||
; /* go to byte boundary */
|
||||
(DUMPBITS (bitwise-and bk 7))
|
||||
|
||||
; /* get the length and its complement */
|
||||
(NEEDBITS 16)
|
||||
(let ([n (bitwise-and bb #xffff)])
|
||||
(DUMPBITS 16)
|
||||
(NEEDBITS 16)
|
||||
(unless (= n (bitwise-and bb #xffff))
|
||||
(error 'inflate "error in compressed data")
|
||||
(return #f)) ; /* error in compressed data */
|
||||
(DUMPBITS 16)
|
||||
|
||||
; /* read and output the compressed data */
|
||||
(let loop ([n n])
|
||||
(when (positive? n)
|
||||
(NEEDBITS 8)
|
||||
(string-set! slide wp (integer->char (bitwise-and bb #xff)))
|
||||
(set! wp (add1 wp))
|
||||
(check-flush)
|
||||
(DUMPBITS 8)
|
||||
(loop (sub1 n))))
|
||||
|
||||
#t)))
|
||||
|
||||
(define (inflate_fixed)
|
||||
; /* decompress an inflated type 1 (fixed Huffman codes) block. We should
|
||||
; either replace this with a custom decoder, or at least precompute the
|
||||
; Huffman tables. */
|
||||
|
||||
(define l (make-vector 288))
|
||||
|
||||
(step 0 < 144 add1 (lambda (i) (vector-set! l i 8)))
|
||||
(step 144 < 256 add1 (lambda (i) (vector-set! l i 9)))
|
||||
(step 256 < 280 add1 (lambda (i) (vector-set! l i 7)))
|
||||
(step 280 < 288 add1 (lambda (i) (vector-set! l i 8)))
|
||||
|
||||
(let-values ([(tl bl ok?)
|
||||
(huft_build l 288 257 cplens cplext 7 #f)])
|
||||
|
||||
(if (not ok?)
|
||||
#f
|
||||
(begin
|
||||
(step 0 < 30 add1 (lambda (i) (vector-set! l i 5)))
|
||||
(let-values ([(td bd ok?)
|
||||
(huft_build l 30 0 cpdist cpdext 5 #t)])
|
||||
(if (not ok?)
|
||||
#f
|
||||
; /* decompress until an end-of-block code */
|
||||
(inflate_codes tl td bl bd)))))))
|
||||
|
||||
(define (inflate_dynamic)
|
||||
; /* decompress an inflated type 2 (dynamic Huffman codes) block. */
|
||||
|
||||
(let/ec return
|
||||
|
||||
; /* read in table lengths */
|
||||
; (define junk1 (begin (NEEDBITS 5) (printf "~s ~s~n" bb bk)))
|
||||
(define nl (+ 257 (bitwise-and (GETBITS 5) #x1f)))
|
||||
; (define junk2 (begin (NEEDBITS 5) (printf "~s ~s~n" bb bk)))
|
||||
(define nd (+ 1 (bitwise-and (GETBITS 5) #x1f)))
|
||||
; (define junk3 (begin (NEEDBITS 4) (printf "~s ~s~n" bb bk)))
|
||||
(define nb (+ 4 (bitwise-and (GETBITS 4) #xf)))
|
||||
|
||||
; (define junk8 (printf "~s ~s ~s~n" nl nd nb))
|
||||
|
||||
(define ll (make-vector (+ 286 30)))
|
||||
(define i 0)
|
||||
(define l 0)
|
||||
|
||||
(if (or (> nl 286) (> nd 30))
|
||||
(begin
|
||||
(error 'inflate "bad lengths")
|
||||
#f) ; /* bad lengths */
|
||||
(begin
|
||||
; /* read in bit-length-code lengths */
|
||||
(step 0 < nb add1
|
||||
(lambda (j)
|
||||
(vector-set! ll (vector-ref border j) (bitwise-and (GETBITS 3) 7))))
|
||||
(step nb < 19 add1
|
||||
(lambda (j)
|
||||
(vector-set! ll (vector-ref border j) 0)))
|
||||
|
||||
; /* build decoding table for trees--single level, 7 bit lookup */
|
||||
(let-values ([(tl bl ok?)
|
||||
(huft_build ll 19 19 null null 7 #f)])
|
||||
(if (not ok?)
|
||||
#f
|
||||
(begin
|
||||
; /* read in literal and distance code lengths */
|
||||
(let ([n (+ nl nd)]
|
||||
[m (vector-ref mask_bits bl)])
|
||||
; (printf "bl: ~s~n" bl)
|
||||
(set! i 0)
|
||||
(set! l 0)
|
||||
(let loop ()
|
||||
(when (< i n)
|
||||
(NEEDBITS bl)
|
||||
(let* ([pos (bitwise-and bb m)]
|
||||
[td (vector-ref tl pos)]
|
||||
[dmp (huft-b td)]
|
||||
[j (huft-v td)]
|
||||
[set-lit
|
||||
(lambda (j l)
|
||||
(when (> (+ i j) n)
|
||||
(error 'inflate "bad hop")
|
||||
(return #f))
|
||||
(let loop ([j j])
|
||||
(unless (zero? j)
|
||||
(vector-set! ll i l)
|
||||
(set! i (add1 i))
|
||||
(loop (sub1 j)))))])
|
||||
(DUMPBITS dmp)
|
||||
; (printf "pos: ~s j: ~s l: ~s i: ~s~n" pos j l i)
|
||||
(cond
|
||||
[(< j 16) ; /* length of code in bits (0..15) */
|
||||
(vector-set! ll i j)
|
||||
(set! l j) ; /* save last length in l */
|
||||
(set! i (add1 i))]
|
||||
[(= j 16) ; /* repeat last length 3 to 6 times */
|
||||
(let ([j (+ 3 (bitwise-and (GETBITS 2) 3))])
|
||||
(set-lit j l))]
|
||||
[(= j 17) ; /* 3 to 10 zero length codes */
|
||||
(let ([j (+ 3 (bitwise-and (GETBITS 3) 7))])
|
||||
(set-lit j 0)
|
||||
(set! l 0))]
|
||||
[else ; /* j == 18: 11 to 138 zero length codes */
|
||||
(let ([j (+ 11 (bitwise-and (GETBITS 7) #x7f))])
|
||||
(set-lit j 0)
|
||||
(set! l 0))]))
|
||||
(loop)))
|
||||
|
||||
; /* build the decoding tables for literal/length and distance codes */
|
||||
(let-values ([(tl bl ok?)
|
||||
(huft_build ll nl 257 cplens cplext lbits #f)])
|
||||
(if (not ok?)
|
||||
(begin
|
||||
(error 'inflate "incomplete code set")
|
||||
#f) ; /* incomplete code set */
|
||||
(let-values ([(td bd ok?)
|
||||
(huft_build (subvector ll nl) nd 0 cpdist cpdext dbits #f)])
|
||||
(if (not ok?)
|
||||
(begin
|
||||
(error 'inflate "incomplete code set")
|
||||
#f) ; /* incomplete code set */
|
||||
; /* decompress until an end-of-block code */
|
||||
(inflate_codes tl td bl bd)))))))))))))
|
||||
|
||||
(define (inflate_block)
|
||||
; return values: /* last block flag */ ok?
|
||||
; /* decompress an inflated block */
|
||||
|
||||
(define e-result (bitwise-and (GETBITS 1) 1))
|
||||
|
||||
; /* read in block type */
|
||||
(define t (bitwise-and (GETBITS 2) 3))
|
||||
|
||||
(values e-result
|
||||
(case t
|
||||
[(2) (inflate_dynamic)]
|
||||
[(0) (inflate_stored)]
|
||||
[(1) (inflate_fixed)]
|
||||
[else (error 'inflate "unknown inflate type")
|
||||
#f])))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; inflate starts here
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
; /* decompress an inflated entry */
|
||||
; /* initialize window, bit buffer */
|
||||
(set! wp 0)
|
||||
(set! bk 0)
|
||||
(set! bb 0)
|
||||
|
||||
|
||||
; /* decompress until the last block */
|
||||
(let loop ()
|
||||
(let-values ([(e ok?) (inflate_block)])
|
||||
(if ok?
|
||||
(if (zero? e)
|
||||
(loop)
|
||||
(begin
|
||||
; /* Undo too much lookahead. The next read will be byte aligned so we
|
||||
; * can discard unused bits in the last meaningful byte.
|
||||
; */
|
||||
(let loop ()
|
||||
(when (> bk 8)
|
||||
(set! bk (- bk 8))
|
||||
; do something: inptr--
|
||||
(loop)))
|
||||
(flush-output wp)
|
||||
#t = (void)))
|
||||
#f))))
|
||||
|
||||
(define (make-small-endian . chars)
|
||||
(let loop ([chars chars][n 0][mult 1])
|
||||
(if (null? chars)
|
||||
n
|
||||
(loop (cdr chars)
|
||||
(+ n (* mult (char->integer (car chars))))
|
||||
(* mult 256)))))
|
||||
|
||||
(define (do-gunzip in out name-filter)
|
||||
(let ([header1 (read-char in)]
|
||||
[header2 (read-char in)])
|
||||
(unless (and (char=? header1 #\037) (char=? header2 #\213))
|
||||
(error 'gnu-unzip "bad header")))
|
||||
(let ([compression-type (read-char in)])
|
||||
(unless (char=? compression-type #\010)
|
||||
(error 'gnu-unzip "unknown compression type")))
|
||||
(let* ([flags (char->integer (read-char in))]
|
||||
[ascii? (positive? (bitwise-and flags #b1))]
|
||||
[continuation? (positive? (bitwise-and flags #b10))]
|
||||
[has-extra-field? (positive? (bitwise-and flags #b100))]
|
||||
[has-original-filename? (positive? (bitwise-and flags #b1000))]
|
||||
[has-comment? (positive? (bitwise-and flags #b10000))]
|
||||
[encrypted? (positive? (bitwise-and flags #b100000))])
|
||||
(when encrypted?
|
||||
(error 'gnu-unzip "cannot unzip encrypted file"))
|
||||
(when continuation?
|
||||
(error 'gnu-unzip "cannot handle multi-part files"))
|
||||
(let ([unix-mod-time (make-small-endian (read-char in) (read-char in)
|
||||
(read-char in) (read-char in))]
|
||||
[extra-flags (read-char in)]
|
||||
[source-os (read-char in)])
|
||||
(when continuation?
|
||||
(let ([part-number (make-small-endian (read-char in) (read-char in))])
|
||||
'ok))
|
||||
(when has-extra-field?
|
||||
(let ([len (make-small-endian (read-char in) (read-char in))])
|
||||
(let loop ([len len])
|
||||
(unless (zero? len)
|
||||
(read-char in)
|
||||
(loop (sub1 len))))))
|
||||
(let* ([read-null-term-string
|
||||
(lambda ()
|
||||
(let loop ([s null])
|
||||
(let ([r (read-char in)])
|
||||
(if (char=? #\null r)
|
||||
(list->string (reverse! s))
|
||||
(loop (cons r s))))))]
|
||||
[original-filename (and has-original-filename?
|
||||
(read-null-term-string))]
|
||||
[comment (and has-comment? (read-null-term-string))])
|
||||
(when encrypted?
|
||||
(let loop ([n 12])
|
||||
(unless (zero? n)
|
||||
(read-char in)
|
||||
(loop (sub1 n)))))
|
||||
|
||||
(let-values ([(out close?) (if out
|
||||
(values out #f)
|
||||
(let-values ([(fn orig?)
|
||||
(if original-filename
|
||||
(values original-filename #t)
|
||||
(values "unzipped" #f))])
|
||||
(values (open-output-file (name-filter fn orig?) 'truncate)
|
||||
#t)))])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda () (inflate in out))
|
||||
(lambda () (when close? (close-output-port out)))))))))
|
||||
|
||||
(define (gunzip-through-ports in out)
|
||||
(do-gunzip in out void))
|
||||
|
||||
(define gunzip
|
||||
(case-lambda
|
||||
[(src) (gunzip src (lambda (name from-file?) name))]
|
||||
[(src name-filter)
|
||||
(let ([in (open-input-file src 'binary)])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda () (do-gunzip in #f name-filter))
|
||||
(lambda () (close-input-port in))))]))
|
||||
)
|
||||
4
collects/mzlib/inflates.ss
Normal file
4
collects/mzlib/inflates.ss
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
(define-signature mzlib:inflate^
|
||||
(inflate
|
||||
gunzip-through-ports
|
||||
gunzip))
|
||||
7
collects/mzlib/inflateu.ss
Normal file
7
collects/mzlib/inflateu.ss
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
|
||||
(require-library "inflates.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "refer.ss"))
|
||||
|
||||
(define mzlib:inflate@ (require-library-unit/sig "inflater.ss"))
|
||||
21
collects/mzlib/info.ss
Normal file
21
collects/mzlib/info.ss
Normal file
|
|
@ -0,0 +1,21 @@
|
|||
|
||||
(let ([elaboration-time-files
|
||||
(list "awk.ss" "compatm.ss" "defstru.ss"
|
||||
"macro.ss" "match.ss"
|
||||
"shared.ss" "restarts.ss" "cmdlinem.ss"
|
||||
"spidey.ss" "synrule.ss" "trace.ss"
|
||||
"cmdlines.ss" "dates.ss" "strings.ss"
|
||||
"compats.ss" "files.ss" "threads.ss" "transcrs.ss"
|
||||
"compiles.ss" "functios.ss" "pconvers.ss"
|
||||
"inflates.ss" "prettys.ss" "maths.ss"
|
||||
"cores.ss" "coreflats.ss" "invoke.ss"
|
||||
"mzlibs.ss" "mzlibflats.ss")])
|
||||
(lambda (request failure)
|
||||
(case request
|
||||
[(name) "MzLib"]
|
||||
[(compile-prefix) '(begin
|
||||
(require-library "mzlibflats.ss"))]
|
||||
[(compile-omit-files) (append elaboration-time-files
|
||||
(list "refer.ss" "letplsrc.ss"))]
|
||||
[(compile-elaboration-zos) elaboration-time-files]
|
||||
[else (failure)])))
|
||||
14
collects/mzlib/invoke.ss
Normal file
14
collects/mzlib/invoke.ss
Normal file
|
|
@ -0,0 +1,14 @@
|
|||
|
||||
(begin-elaboration-time
|
||||
(define-values (define-values/invoke-unit
|
||||
define-values/invoke-unit/sig
|
||||
global-define-values/invoke-unit
|
||||
global-define-values/invoke-unit/sig)
|
||||
(invoke-unit (require-library "invoker.ss"))))
|
||||
|
||||
(define-macro define-values/invoke-unit define-values/invoke-unit)
|
||||
(define-macro define-values/invoke-unit/sig define-values/invoke-unit/sig)
|
||||
(define-macro global-define-values/invoke-unit global-define-values/invoke-unit)
|
||||
(define-macro global-define-values/invoke-unit/sig global-define-values/invoke-unit/sig)
|
||||
|
||||
|
||||
179
collects/mzlib/invoker.ss
Normal file
179
collects/mzlib/invoker.ss
Normal file
|
|
@ -0,0 +1,179 @@
|
|||
|
||||
; For shadowing (during compile):
|
||||
(let ([define-values/invoke-unit void]
|
||||
[define-values/invoke-unit/sig void]
|
||||
[global-define-values/invoke-unit void]
|
||||
[global-define-values/invoke-unit/sig void])
|
||||
(unit
|
||||
(import)
|
||||
(export)
|
||||
|
||||
(define (extract-signature sig badsyntax)
|
||||
; A cheesy way of expanding the saignature: use the compound-unit/sig
|
||||
; macro implementation. Construct an expression, expand it, and
|
||||
; then pull the result back apart.
|
||||
(with-handlers ([(lambda (x) (not (exn:misc:user-break? x)))
|
||||
(lambda (x) (badsyntax sig "bad signature"))])
|
||||
(let ([expr (local-expand-defmacro `(#%compound-unit/sig
|
||||
(import)
|
||||
(link [A : ,sig (0)]
|
||||
[B : () (0 A)])
|
||||
(export)))]
|
||||
[find-expr (lambda (l v)
|
||||
(let loop ([l l][queue null])
|
||||
(cond
|
||||
[(and (pair? l) (eq? (car l) v))
|
||||
l]
|
||||
[(pair? l)
|
||||
; breadth first:
|
||||
(loop (cdr l) (cons (car l) queue))]
|
||||
[(pair? queue)
|
||||
(loop (car queue) (cdr queue))]
|
||||
[else #f])))])
|
||||
(let* ([verify (find-expr expr '#%verify-linkage-signature-match)]
|
||||
[exploded (car (cadr (list-ref verify 4)))]
|
||||
[link (find-expr (find-expr expr '#%make-unit-with-signature)
|
||||
'link)]
|
||||
[b-line (caddr link)]
|
||||
[a-import (cadr (cadr b-line))]
|
||||
[flattened (cdr a-import)])
|
||||
(values exploded flattened)))))
|
||||
|
||||
(define (extract-named-signature sig badsyntax)
|
||||
(let-values ([(prefix sig) (if (and (list? sig)
|
||||
(= 3 (length sig))
|
||||
(eq? (cadr sig) ':))
|
||||
(values (car sig) (caddr sig))
|
||||
(values #f sig))])
|
||||
(let-values ([(exploded flattened) (extract-signature sig badsyntax)])
|
||||
(if prefix
|
||||
(values (cons prefix exploded)
|
||||
(let ([p (string-append (symbol->string prefix) ":")])
|
||||
(map (lambda (s)
|
||||
(string->symbol
|
||||
(string-append
|
||||
p
|
||||
(symbol->string s))))
|
||||
flattened)))
|
||||
(values (cons 'name exploded) flattened)))))
|
||||
|
||||
(define (do-define-values/invoke-unit global? exports unit prefix imports)
|
||||
(let* ([badsyntax (lambda (s why)
|
||||
(raise-syntax-error
|
||||
(if global?
|
||||
'global-define-values/invoke-unit
|
||||
'define-values/invoke-unit)
|
||||
(format "bad syntax (~a)" why)
|
||||
`(,(if global?
|
||||
'global-define-values/invoke-unit
|
||||
'define-values/invoke-unit)
|
||||
,exports
|
||||
,unit ,prefix ,@imports)
|
||||
s))]
|
||||
[symcheck (lambda (s)
|
||||
(or (symbol? s)
|
||||
(badsyntax s "not an identifier")))])
|
||||
(unless (list? exports)
|
||||
(badsyntax exports "not a sequence of identifiers"))
|
||||
(for-each symcheck exports)
|
||||
(when prefix
|
||||
(unless (symbol? prefix)
|
||||
(badsyntax prefix "prefix is not an identifier")))
|
||||
(for-each symcheck imports)
|
||||
|
||||
(let* ([tagged-exports (if prefix
|
||||
(let ([prefix (string-append
|
||||
(symbol->string prefix)
|
||||
":")])
|
||||
(map (lambda (s)
|
||||
(string->symbol
|
||||
(string-append
|
||||
prefix
|
||||
(symbol->string s))))
|
||||
exports))
|
||||
exports)]
|
||||
[extract-unit `(#%unit
|
||||
(import ,@exports)
|
||||
(export)
|
||||
(#%values ,@exports))]
|
||||
[invoke-unit
|
||||
`(#%invoke-unit
|
||||
(#%compound-unit
|
||||
(import ,@imports)
|
||||
(link [unit-to-invoke (,unit ,@imports)]
|
||||
[export-extractor (,extract-unit (unit-to-invoke ,@exports))])
|
||||
(export))
|
||||
,@imports)])
|
||||
(if global?
|
||||
`(#%let-values ([,tagged-exports ,invoke-unit])
|
||||
,@(map
|
||||
(lambda (x)
|
||||
`(#%global-defined-value ',x ,x))
|
||||
tagged-exports))
|
||||
`(#%define-values ,tagged-exports ,invoke-unit)))))
|
||||
|
||||
(define define-values/invoke-unit
|
||||
(case-lambda
|
||||
[(exports unit name . imports) (do-define-values/invoke-unit #f exports unit name imports)]
|
||||
[(exports unit) (do-define-values/invoke-unit #f exports unit #f null)]))
|
||||
|
||||
(define global-define-values/invoke-unit
|
||||
(case-lambda
|
||||
[(exports unit name . imports) (do-define-values/invoke-unit #t exports unit name imports)]
|
||||
[(exports unit) (do-define-values/invoke-unit #t exports unit #f null)]))
|
||||
|
||||
(define (do-define-values/invoke-unit/sig global? signame unit prefix imports)
|
||||
(let* ([formname (if global?
|
||||
'global-define-values/invoke-unit/sig
|
||||
'define-values/invoke-unit/sig)]
|
||||
[badsyntax (lambda (s why)
|
||||
(raise-syntax-error
|
||||
formname
|
||||
(format "bad syntax (~a)" why)
|
||||
`(,formname
|
||||
,signame ,unit ,prefix ,@imports)
|
||||
s))]
|
||||
[unit-var (gensym)])
|
||||
(let-values ([(ex-exploded ex-flattened) (extract-signature signame badsyntax)]
|
||||
[(im-explodeds im-flatteneds)
|
||||
(let loop ([l imports][el null][fl null])
|
||||
(if (null? l)
|
||||
(values (reverse! el) (reverse! fl))
|
||||
(let-values ([(e f) (extract-named-signature (car l) badsyntax)])
|
||||
(loop (cdr l) (cons e el) (cons f fl)))))])
|
||||
`(,(if global?
|
||||
'global-define-values/invoke-unit
|
||||
'define-values/invoke-unit)
|
||||
,ex-flattened
|
||||
(let ([,unit-var ,unit])
|
||||
(#%verify-linkage-signature-match
|
||||
',formname
|
||||
'(invoke)
|
||||
(#%list ,unit-var)
|
||||
'(,ex-exploded)
|
||||
'(,im-explodeds))
|
||||
(#%unit/sig->unit ,unit-var))
|
||||
,(if (or (eq? prefix #f)
|
||||
(symbol? prefix))
|
||||
prefix
|
||||
(badsyntax prefix "prefix is not #f or a symbol"))
|
||||
,@(apply append im-flatteneds)))))
|
||||
|
||||
(define define-values/invoke-unit/sig
|
||||
(case-lambda
|
||||
[(signame unit prefix . imports)
|
||||
(do-define-values/invoke-unit/sig #f signame unit prefix imports)]
|
||||
[(signame unit)
|
||||
(do-define-values/invoke-unit/sig #f signame unit #f null)]))
|
||||
|
||||
(define global-define-values/invoke-unit/sig
|
||||
(case-lambda
|
||||
[(signame unit prefix . imports)
|
||||
(do-define-values/invoke-unit/sig #t signame unit prefix imports)]
|
||||
[(signame unit)
|
||||
(do-define-values/invoke-unit/sig #t signame unit #f null)]))
|
||||
|
||||
(values define-values/invoke-unit
|
||||
define-values/invoke-unit/sig
|
||||
global-define-values/invoke-unit
|
||||
global-define-values/invoke-unit/sig)))
|
||||
426
collects/mzlib/letplsrc.ss
Normal file
426
collects/mzlib/letplsrc.ss
Normal file
|
|
@ -0,0 +1,426 @@
|
|||
(require-library "macro.ss")
|
||||
(require-library "match.ss")
|
||||
|
||||
(define-macro rmatch
|
||||
(local [(define-struct child (destruct values traversal))
|
||||
(define-struct traversal (children))
|
||||
|
||||
(define-struct id (id))
|
||||
(define-struct prepeat (pattern))
|
||||
(define-struct trepeat (traversal))
|
||||
|
||||
(define parse-pattern
|
||||
(lambda (pattern)
|
||||
(cond
|
||||
[(pair? pattern)
|
||||
(let ([p1 (car pattern)]
|
||||
[p2 (cdr pattern)])
|
||||
(let*-values ([(left left-values left-names) (parse-pattern p1)]
|
||||
[(right right-values right-names) (parse-pattern p2)])
|
||||
(values
|
||||
(make-traversal (list (make-child '#%car left-values left) (make-child '#%cdr right-values right)))
|
||||
(+ left-values right-values)
|
||||
(append left-names right-names))))]
|
||||
[(box? pattern)
|
||||
(let ([p (unbox pattern)])
|
||||
(let*-values ([(sub-pat sub-values sub-names) (parse-pattern p)])
|
||||
(values
|
||||
(make-traversal (list (make-child '#%unbox sub-values sub-pat)))
|
||||
sub-values
|
||||
sub-names)))]
|
||||
[(vector? pattern)
|
||||
(let ([pats (vector->list pattern)])
|
||||
(let loop ([pats pats]
|
||||
[index 0]
|
||||
[l null]
|
||||
[vals 0]
|
||||
[names null])
|
||||
(cond
|
||||
[(null? pats) (values (make-traversal (reverse l))
|
||||
vals
|
||||
(reverse names))]
|
||||
[else (let-values ([(sub-pat sub-values sub-names) (parse-pattern (car pats))])
|
||||
(loop (cdr pats)
|
||||
(+ index 1)
|
||||
(cons (make-child `(#%lambda (v) (#%vector-ref v ,index)) sub-values sub-pat)
|
||||
l)
|
||||
(+ vals sub-values)
|
||||
(append sub-names names)))])))]
|
||||
[(prepeat? pattern)
|
||||
(let-values ([(sub-traversal sub-values sub-names)
|
||||
(parse-pattern (prepeat-pattern pattern))])
|
||||
(values (make-trepeat sub-traversal)
|
||||
sub-values
|
||||
sub-names))]
|
||||
[(id? pattern)
|
||||
(values pattern
|
||||
1
|
||||
(list (id-id pattern)))]
|
||||
[(or (symbol? pattern)
|
||||
(null? pattern)
|
||||
(number? pattern)
|
||||
(char? pattern)
|
||||
(string? pattern))
|
||||
(values pattern 0 null)]
|
||||
[else (error 'parse-pattern "unrecognized pattern: ~a" pattern)])))
|
||||
|
||||
(define n-names
|
||||
(lambda (n prefix)
|
||||
(cond
|
||||
[(zero? n) null]
|
||||
[else (cons (gensym prefix) (n-names (sub1 n) prefix))])))
|
||||
|
||||
(define traverse-traversal
|
||||
(lambda (t above-name)
|
||||
(cond
|
||||
[(traversal? t)
|
||||
(let* ([children (traversal-children t)])
|
||||
(let ([child-namess (map (lambda (c) (n-names (child-values c) "child")) children)]
|
||||
[piece-names (map (lambda (c) (gensym "destruct")) children)]
|
||||
[build-piece
|
||||
(lambda (name child)
|
||||
`[,name (,(child-destruct child) ,above-name)])]
|
||||
[recur (lambda (child piece-name child-names)
|
||||
`[,child-names ,(traverse-traversal (child-traversal child) piece-name)])])
|
||||
`(let ,(map build-piece piece-names children)
|
||||
(let-values ,(map recur children piece-names child-namess)
|
||||
(values ,@(apply append child-namess))))))]
|
||||
[(trepeat? t)
|
||||
(let* ([sub-t (trepeat-traversal t)]
|
||||
[l (gensym "...l")]
|
||||
[hd (gensym "...hd")]
|
||||
[loop (gensym "...loop")]
|
||||
[value-count
|
||||
(cond
|
||||
[(traversal? sub-t) (apply + (map child-values (traversal-children sub-t)))]
|
||||
[(id? sub-t) 1]
|
||||
[else 0])]
|
||||
[n-list (lambda (n f)
|
||||
(let loop ([n n])
|
||||
(cond
|
||||
[(zero? n) null]
|
||||
[else (cons (f (- n 1)) (loop (- n 1)))])))]
|
||||
[sub-names (n-list value-count
|
||||
(lambda (n) (gensym (format "...sub~a" n))))]
|
||||
[rec-sub-names (n-list value-count
|
||||
(lambda (n) (gensym (format "...rec~a" n))))])
|
||||
`(let ,loop ([,l ,above-name])
|
||||
(cond
|
||||
[(null? ,l) (values ,@(n-list value-count (lambda (i) 'null)))]
|
||||
[(pair? ,l) (let ([,hd (car ,l)])
|
||||
(let-values ([,sub-names ,(traverse-traversal sub-t hd)]
|
||||
[,rec-sub-names (,loop (cdr ,l))])
|
||||
(values ,@(map (lambda (sub rec) `(cons ,sub ,rec))
|
||||
sub-names
|
||||
rec-sub-names))))]
|
||||
[else (error 'rmatch "didn't find a list: found: ~a" ,above-name)])))]
|
||||
|
||||
|
||||
[(id? t) above-name]
|
||||
[(number? t) `(if (= ,t ,above-name)
|
||||
(values)
|
||||
(error 'rmatch "didn't find number: ~a, found: ~a" ,t ,above-name))]
|
||||
[(symbol? t) `(if (eq? ,above-name ',t)
|
||||
(values)
|
||||
(error 'rmatch "didn't find symbol: ~a, found: ~a" ',t ,above-name))]
|
||||
[(null? t) `(if (null? ,above-name)
|
||||
(values)
|
||||
(error 'rmatch "expected null, found: ~a" ,above-name))]
|
||||
[(string? t) `(if (and (string? ,above-name) (string=? ,above-name ,t))
|
||||
(values)
|
||||
(error 'rmatch "expected ~s, found: ~s" ,t ,above-name))]
|
||||
[(char? t) `(if (eq? ,above-name ,t)
|
||||
(values)
|
||||
(error 'rmatch "expected ~s, found: ~s" ,t ,above-name))]
|
||||
[else (error 'traverse-traversal "unknown input: ~s~n" t)])))
|
||||
|
||||
(define generate-code
|
||||
(lambda (traversal names body)
|
||||
(let ([input (gensym "input")])
|
||||
`(lambda (,input)
|
||||
(let-values ([,names ,(traverse-traversal traversal input)])
|
||||
,body)))))
|
||||
|
||||
;; takes the text of a pattern
|
||||
;; and translates it into an example pattern
|
||||
;; with symbols at the positions
|
||||
;; where identifers go
|
||||
;; eg '(cons x y) becomes (cons 'x 'y)
|
||||
;; and `(,x ,y) becomse (list 'x 'y)
|
||||
(define translation-namespace (make-namespace 'empty))
|
||||
|
||||
(define _1
|
||||
(let* ([tmp-namespace (make-namespace)]
|
||||
[add-already-macro
|
||||
(lambda (m-name)
|
||||
(let ([m-value
|
||||
(parameterize ([current-namespace tmp-namespace])
|
||||
(global-defined-value m-name))])
|
||||
(parameterize ([current-namespace translation-namespace])
|
||||
(global-defined-value m-name m-value))))]
|
||||
[add-not-yet-macro
|
||||
(lambda (m-name function)
|
||||
(parameterize ([current-namespace tmp-namespace])
|
||||
(eval `(define-macro ,m-name ,function)))
|
||||
(add-already-macro m-name))])
|
||||
|
||||
(global-defined-value 'translation-namespace translation-namespace)
|
||||
|
||||
(add-already-macro 'quasiquote)
|
||||
(add-already-macro '#%quasiquote)
|
||||
(add-already-macro 'quote)
|
||||
(add-already-macro '#%quote)
|
||||
(add-not-yet-macro 'list
|
||||
(lambda in
|
||||
(let loop ([l in])
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[else `(#%cons ,(car l) ,(loop (cdr l)))]))))
|
||||
(add-not-yet-macro '... (lambda (x) `(#%repeat ,x)))
|
||||
(add-not-yet-macro 'repeat (lambda (x) `(#%repeat ,x)))
|
||||
(add-not-yet-macro 'box (lambda (x) `(#%box ,x)))
|
||||
(add-not-yet-macro 'cons (lambda (x y) `(#%cons ,x ,y)))
|
||||
(add-not-yet-macro 'vector (lambda x `(#%vector ,@x)))))
|
||||
|
||||
(define translate-pattern
|
||||
(lambda (pattern)
|
||||
(let ([expanded (parameterize ([current-namespace translation-namespace])
|
||||
(expand-defmacro pattern))]
|
||||
[dups (make-hash-table)])
|
||||
(values
|
||||
dups
|
||||
(let loop ([in expanded])
|
||||
(match in
|
||||
[`(#%repeat ,p) (make-prepeat (loop p))]
|
||||
[`(#%cons ,p1 ,p2) (cons (loop p1) (loop p2))]
|
||||
[`(#%box ,p) (box (loop p))]
|
||||
[`(#%vector ,@ps) (apply vector (map loop ps))]
|
||||
[`(#%quote ,p) p]
|
||||
[`null null]
|
||||
[(? symbol? in)
|
||||
(let/ec k
|
||||
(let ([new-id (gensym "rmatch:dup")])
|
||||
(hash-table-put!
|
||||
dups
|
||||
in
|
||||
(cons
|
||||
new-id
|
||||
(hash-table-get
|
||||
dups
|
||||
in (lambda ()
|
||||
(hash-table-put! dups in null)
|
||||
(k (make-id in))))))
|
||||
(make-id new-id)))]
|
||||
[(or (? number? in) (? char? in) (? string? in)) in]
|
||||
[(? null? in) null]
|
||||
[x (error 'translate-pattern "unrecognized pattern: ~s, in ~s"
|
||||
x pattern)]))))))
|
||||
|
||||
(define main
|
||||
(lambda (expression pattern-body-pairs)
|
||||
(let*-values ([(main) (gensym "main")]
|
||||
[(inner-k) (gensym "inner-k")]
|
||||
[(outer-k) (gensym "outer-k")])
|
||||
(unless (and (list? pattern-body-pairs)
|
||||
(andmap (lambda (x) (and (list? x) (<= 2 (length x))))
|
||||
pattern-body-pairs))
|
||||
(error 'rmatch
|
||||
"expected body of lists of length at least two, patterns and results, got: ~a"
|
||||
pattern-body-pairs))
|
||||
`(let ([,main ,expression])
|
||||
(let/ec ,outer-k
|
||||
,@(map (lambda (pattern-body-pair)
|
||||
(let*-values ([(pattern) (car pattern-body-pair)]
|
||||
[(bodies) (cdr pattern-body-pair)]
|
||||
[(dups translation) (translate-pattern pattern)]
|
||||
[(traversal names-count names)
|
||||
(parse-pattern translation)]
|
||||
[(code) (traverse-traversal traversal main)]
|
||||
[(dup-vars) (let loop ([dups (hash-table-map dups cons)])
|
||||
(cond
|
||||
[(null? dups) null]
|
||||
[else (if (= (length (car dups)) 1)
|
||||
(loop (cdr dups))
|
||||
(cons (car dups) (loop (cdr dups))))]))])
|
||||
`(let/ec ,inner-k
|
||||
(let-values ([,names
|
||||
(parameterize ([current-exception-handler
|
||||
(lambda (exn)
|
||||
;(display (exn-message exn))
|
||||
;(newline)
|
||||
(,inner-k #f))])
|
||||
,code)])
|
||||
(unless (and ,@(map (lambda (vars) `(equal? ,@vars))
|
||||
dup-vars))
|
||||
(,inner-k #f))
|
||||
(call-with-values (lambda () (begin ,@bodies))
|
||||
,outer-k)))))
|
||||
pattern-body-pairs)
|
||||
(error 'rmatch "no patterns matched"))))))]
|
||||
(lambda (x y) (main x y))))
|
||||
|
||||
(define-macro let+
|
||||
(lambda (bindings . bodies)
|
||||
(let* ([syn-error
|
||||
(lambda (msg expr)
|
||||
(raise-syntax-error 'let+ msg
|
||||
`(let+ ,bindings ,@bodies)
|
||||
expr))]
|
||||
[expand-pattern
|
||||
(lambda (x)
|
||||
(match x
|
||||
[`(values ,(? symbol? x) ...) x]
|
||||
[(? symbol? x) `(,x)]
|
||||
[x (syn-error "invalid pattern" x)]))]
|
||||
[get-patterns
|
||||
(lambda (x)
|
||||
(match x
|
||||
[`(values ,x ...) x]
|
||||
[else `(,x)]))]
|
||||
|
||||
[single-binding
|
||||
(lambda (binding E body)
|
||||
(let* ([patterns (get-patterns binding)]
|
||||
[gensyms (map (lambda (x) (gensym "pattern")) patterns)])
|
||||
`(let-values ([,gensyms ,E])
|
||||
,(let loop ([patterns patterns]
|
||||
[gensyms gensyms])
|
||||
(cond
|
||||
[(null? patterns) body]
|
||||
[else `(rmatch ,(car gensyms)
|
||||
([,(car patterns)
|
||||
,(loop (cdr patterns) (cdr gensyms))]))])))))]
|
||||
[multiple-bindings
|
||||
(lambda (binding E body)
|
||||
`(let-values ,(map list (map expand-pattern binding) E)
|
||||
,body))]
|
||||
[recursive-single-binding
|
||||
(lambda (binding E body)
|
||||
`(letrec-values ([,(expand-pattern binding) ,E])
|
||||
,body))]
|
||||
[recursive-multiple-bindings
|
||||
(lambda (binding E body)
|
||||
`(letrec-values ,(map (lambda (x y) `(,x ,y))
|
||||
(map expand-pattern binding)
|
||||
E)
|
||||
,body))]
|
||||
[translate-binding
|
||||
(lambda (binding body)
|
||||
(match binding
|
||||
[`(val ,B ,E) (single-binding B E body)]
|
||||
[`(vals (,B ,E) ...) (multiple-bindings B E body)]
|
||||
[`(rec ,B ,E) (recursive-single-binding B E body)]
|
||||
[`(recs (,B ,E) ...) (recursive-multiple-bindings B E body)]
|
||||
[`(_ ,E ...) `(begin ,@E ,body)]
|
||||
[x (syn-error "invalid binding" x)]))])
|
||||
(unless (and (list? bindings)
|
||||
(andmap (lambda (x) (and (list? x)
|
||||
(<= 2 (length x))
|
||||
(symbol? (car x))))
|
||||
bindings))
|
||||
(syn-error "invalid syntax" bindings))
|
||||
(let loop ([l bindings])
|
||||
(cond
|
||||
[(null? l) `(begin ,@bodies)]
|
||||
[else (translate-binding (car l) (loop (cdr l)))])))))
|
||||
|
||||
|
||||
#|
|
||||
(define (test)
|
||||
|
||||
(define (test-at-x result name)
|
||||
(lambda (pattern value)
|
||||
(let ([test-result (with-handlers ([(lambda (x) 'EXCEPTION-RAISED)
|
||||
(lambda (x)
|
||||
(display
|
||||
(if (exn? x)
|
||||
(exn-message x)
|
||||
x))
|
||||
(newline)
|
||||
#f)])
|
||||
(eval `(rmatch ,value
|
||||
([,pattern x]))))])
|
||||
(unless (equal? result test-result)
|
||||
(error name "failed with pattern: ~s and value ~s, got: ~s" pattern value test-result)))))
|
||||
|
||||
(define (test-equal ans expr)
|
||||
(let ([got (with-handlers ([(lambda (x) #T)
|
||||
(lambda (x)
|
||||
(display
|
||||
(if (exn? x)
|
||||
(exn-message x)
|
||||
x))
|
||||
(newline)
|
||||
'DIFFERENT-FROM-IT-ALL)])
|
||||
(eval expr))])
|
||||
(unless (equal? ans got)
|
||||
(error 'test-equal "~s:~nexpected ~s~n got:~s~n" expr ans got))))
|
||||
|
||||
(define 3-at-x (test-at-x 3 '3-at-x))
|
||||
(define 33s-at-x (test-at-x (list 3 3 3) '33s-at-x))
|
||||
|
||||
(define (plus-val-xy bindings)
|
||||
(unless (equal? (cons 1 3)
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (x)
|
||||
(printf "~a~n"
|
||||
(if (exn? x)
|
||||
(exn-message x)
|
||||
x))
|
||||
#f)])
|
||||
(eval `(let+ ,bindings
|
||||
(cons x y)))))
|
||||
(error 'plus-val-xy "failed with bindings: ~s" bindings)))
|
||||
|
||||
(printf "starting test suite~n")
|
||||
|
||||
(plus-val-xy '([val x 1] [val y 3]))
|
||||
(plus-val-xy '([val (values x y) (values 1 3)]))
|
||||
(plus-val-xy '([val (values (box x) (list y)) (values (box 1) (list 3))]))
|
||||
(plus-val-xy '([vals [x 1] [y 3]]))
|
||||
(plus-val-xy '([vals [(values x y) (values 1 3)]]))
|
||||
;(plus-val-xy '([vals [(values (box x) (list y)) (values (box 3) (list 3))]]))
|
||||
|
||||
(3-at-x 'x 3)
|
||||
(3-at-x '(cons x y) '(cons 3 2))
|
||||
(3-at-x '(list x) '(list 3))
|
||||
(3-at-x '(list 2 x) '(list 2 3))
|
||||
(3-at-x '(vector x) '(vector 3))
|
||||
(3-at-x '(vector x 2) '(vector 3 2))
|
||||
(3-at-x '(vector 2 x) '(vector 2 3))
|
||||
(3-at-x '(box x) '(box 3))
|
||||
(3-at-x '(box (box x)) '(box (box 3)))
|
||||
(3-at-x '(vector 'x `(3) `(,x)) '(vector 'x (list 3) (list 3)))
|
||||
(3-at-x '(vector 'x "abc" #\f `(3) `(,x)) '(vector 'x "abc" #\f (list 3) (list 3)))
|
||||
(3-at-x '`(box ,x) ''(box 3))
|
||||
|
||||
(test-equal 3 '(rmatch (list 3 4) ([(list x x) x] [(list x 4) x])))
|
||||
(test-equal 3 '(rmatch (list 3 3) ([(list x x) x])))
|
||||
|
||||
(test-equal (list 3) '(rmatch (list 3) ([(repeat x) x])))
|
||||
(test-equal (list 'x 'z)
|
||||
'(rmatch (list (list 'x 'y) (list 'z 'w)) ([(repeat `(,x ,y)) x])))
|
||||
(test-equal
|
||||
`(x 1 y)
|
||||
'(rmatch '(letrec ([x 1]) y) ([`(letrec ([,x ,v]) ,b) (list x v b)])))
|
||||
|
||||
(test-equal
|
||||
`((x) (1) y)
|
||||
'(rmatch '(letrec ([x 1]) y) ([`(letrec ,(repeat `[,x ,v]) ,b) (list x v b)])))
|
||||
|
||||
(33s-at-x '(... (box x)) '(list (box 3) (box 3) (box 3)))
|
||||
|
||||
(test-equal 3 '(let ([x 3]) (let+ ([vals [x 1] [y x]]) y)))
|
||||
(test-equal 3 '(let ([x 3]) (let+ ([val x 3] [vals [x 1] [y x]]) y)))
|
||||
|
||||
(test-equal 3 '(let+ ([rec (values x) (lambda (y) (if y 3 (x #t)))]) (x #f)))
|
||||
(test-equal 3 '(let+ ([recs [x (lambda (y) (if y 3 (x #t)))]]) (x #f)))
|
||||
(test-equal 3 '(let+ ([recs [(values x) (lambda (y) (if y 3 (x #t)))]]) (x #f)))
|
||||
|
||||
(test-equal 3 '(let+ ([rec a (lambda () a)] [val b (a)]) 3))
|
||||
|
||||
(printf "all tests passed~n")
|
||||
)
|
||||
|
||||
(test)
|
||||
|#
|
||||
2
collects/mzlib/letplusr.ss
Normal file
2
collects/mzlib/letplusr.ss
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
(unit (import) (export let+)
|
||||
(#%define let+ (#%lambda (bindings . bodies) (#%let-values (((syn-error) (#%lambda (msg expr) (raise-syntax-error (#%quote let+) msg (#%cons (#%quote let+) (#%cons bindings bodies)) expr)))) (#%let-values (((expand-pattern) (#%lambda (x) (#%let-values (((g71) (#%lambda (x) (syn-error "invalid pattern" x)))) (#%if (pair? x) (#%if (#%if (equal? (car x) (#%quote values)) (list? (cdr x)) #f) (#%letrec-values (((g66) (#%lambda (g67 g68) (#%if (null? g67) ((#%lambda (x) x) (reverse g68)) (#%if (symbol? (car g67)) (g66 (cdr g67) (cons (car g67) g68)) (g71 x)))))) (g66 (cdr x) (#%quote ()))) (g71 x)) (#%if (symbol? x) ((#%lambda (x) (#%cons x ())) x) (g71 x))))))) (#%let-values (((single-binding) (#%lambda (sym binding e body) (#%cons sym (#%cons (#%cons (#%cons (expand-pattern binding) (#%cons e ())) ()) (#%cons body ())))))) (#%let-values (((multiple-bindings) (#%lambda (sym binding e body) (#%cons sym (#%cons (map list (map expand-pattern binding) e) (#%cons body ())))))) (#%let-values (((translate-binding) (#%lambda (binding body) (#%let-values (((g90) (#%lambda (x) (syn-error "invalid binding" x)))) (#%if (pair? binding) (#%if (equal? (car binding) (#%quote val)) (#%if (#%if (pair? (cdr binding)) (#%if (pair? (cddr binding)) (null? (cdddr binding)) #f) #f) ((#%lambda (b e) (single-binding (#%quote let-values) b e body)) (cadr binding) (caddr binding)) (g90 binding)) (#%if (equal? (car binding) (#%quote vals)) (#%if (list? (cdr binding)) (#%letrec-values (((g75) (#%lambda (g76 g77 g78) (#%if (null? g76) ((#%lambda (b e) (multiple-bindings (#%quote let-values) b e body)) (reverse g78) (reverse g77)) (#%if (#%if (pair? (car g76)) (#%if (pair? (cdar g76)) (null? (cddar g76)) #f) #f) (g75 (cdr g76) (cons (cadar g76) g77) (cons (caar g76) g78)) (g90 binding)))))) (g75 (cdr binding) (#%quote ()) (#%quote ()))) (g90 binding)) (#%if (equal? (car binding) (#%quote rec)) (#%if (#%if (pair? (cdr binding)) (#%if (pair? (cddr binding)) (null? (cdddr binding)) #f) #f) ((#%lambda (b e) (single-binding (#%quote letrec-values) b e body)) (cadr binding) (caddr binding)) (g90 binding)) (#%if (equal? (car binding) (#%quote recs)) (#%if (list? (cdr binding)) (#%letrec-values (((g81) (#%lambda (g82 g83 g84) (#%if (null? g82) ((#%lambda (b e) (multiple-bindings (#%quote letrec-values) b e body)) (reverse g84) (reverse g83)) (#%if (#%if (pair? (car g82)) (#%if (pair? (cdar g82)) (null? (cddar g82)) #f) #f) (g81 (cdr g82) (cons (cadar g82) g83) (cons (caar g82) g84)) (g90 binding)))))) (g81 (cdr binding) (#%quote ()) (#%quote ()))) (g90 binding)) (#%if (#%if (equal? (car binding) (#%quote _)) (list? (cdr binding)) #f) ((#%lambda (e) (#%cons (#%quote begin) (#%append e (#%cons body ())))) (cdr binding)) (g90 binding)))))) (g90 binding)))))) (#%let-values () (#%if (#%if (list? bindings) (andmap (#%lambda (x) (#%if (list? x) (#%if (<= 2 (length x)) (symbol? (car x)) #f) #f)) bindings) #f) (#%void) (syn-error "invalid syntax" bindings)) (#%letrec-values (((loop) (#%lambda (l) (#%if (null? l) (#%cons (#%quote begin) bodies) (translate-binding (car l) (loop (cdr l))))))) (loop bindings)))))))))))
|
||||
33
collects/mzlib/macro.ss
Normal file
33
collects/mzlib/macro.ss
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(begin-elaboration-time
|
||||
(define-values/invoke-unit (class-asi
|
||||
class*-asi
|
||||
opt-lambda
|
||||
send*
|
||||
local
|
||||
recur
|
||||
rec
|
||||
evcase
|
||||
nor
|
||||
nand
|
||||
signature->symbols)
|
||||
(require-library "macror.ss"))
|
||||
(define-values/invoke-unit (let+)
|
||||
(require-library "letplusr.ss")))
|
||||
|
||||
(define-macro class-asi class-asi)
|
||||
(define-macro class*-asi class*-asi)
|
||||
(define-macro opt-lambda opt-lambda)
|
||||
(define-macro let+ let+)
|
||||
(define-macro send* send*)
|
||||
(define-macro local local)
|
||||
(define-macro recur recur)
|
||||
(define-macro rec rec)
|
||||
(define-macro evcase evcase)
|
||||
(define-macro nor nor)
|
||||
(define-macro nand nand)
|
||||
(define-macro signature->symbols signature->symbols)
|
||||
|
||||
265
collects/mzlib/macror.ss
Normal file
265
collects/mzlib/macror.ss
Normal file
|
|
@ -0,0 +1,265 @@
|
|||
|
||||
(unit
|
||||
(import)
|
||||
(export class-asi
|
||||
class*-asi
|
||||
opt-lambda
|
||||
send*
|
||||
local
|
||||
recur
|
||||
rec
|
||||
evcase
|
||||
nor
|
||||
nand
|
||||
signature->symbols)
|
||||
|
||||
(define class*-asi
|
||||
(lambda (super interfaces . body)
|
||||
(let ([args (gensym)]
|
||||
[super-init 'super-init])
|
||||
`(class* ,super ,interfaces ,args
|
||||
,@body
|
||||
(sequence
|
||||
(apply ,super-init ,args))))))
|
||||
|
||||
(define class-asi
|
||||
(lambda (super . rest)
|
||||
`(class*-asi ,super () ,@rest)))
|
||||
|
||||
(define opt-lambda
|
||||
(lambda (args . body)
|
||||
(let* ([mk-code (lambda () (list* 'opt-lambda args body))]
|
||||
[f (gensym 'opt-lambda-procedure)]
|
||||
[required
|
||||
(let loop ([args args])
|
||||
(if (and (pair? args)
|
||||
(symbol? (car args)))
|
||||
(cons (car args) (loop (cdr args)))
|
||||
'()))]
|
||||
[not-required-with-defaults
|
||||
(let loop ([args args])
|
||||
(if (and (pair? args)
|
||||
(symbol? (car args)))
|
||||
(loop (cdr args))
|
||||
args))]
|
||||
[not-required
|
||||
(let loop ([args not-required-with-defaults])
|
||||
(if (pair? args)
|
||||
(if (pair? (car args))
|
||||
(let ([name (caar args)])
|
||||
(if (symbol? name)
|
||||
(cons name (loop (cdr args)))
|
||||
(raise-syntax-error
|
||||
'opt-lambda
|
||||
"all argument names must be symbols"
|
||||
(mk-code))))
|
||||
(raise-syntax-error 'opt-lambda
|
||||
"all required args must come first"
|
||||
(mk-code)))
|
||||
(if (or (null? args) (symbol? args))
|
||||
args
|
||||
(raise-syntax-error 'opt-lambda
|
||||
"all argument names must be symbols"
|
||||
(mk-code)))))]
|
||||
[defaults
|
||||
(let loop ([args not-required-with-defaults])
|
||||
(if (pair? args)
|
||||
(let ([v (cdar args)])
|
||||
(if (and (pair? v) (null? (cdr v)))
|
||||
(cons (car v) (loop (cdr args)))
|
||||
(raise-syntax-error
|
||||
'opt-lambda
|
||||
"only one default value allowed per argument"
|
||||
(mk-code))))
|
||||
()))])
|
||||
`(letrec ([,f
|
||||
(case-lambda
|
||||
,@(let loop ([required required]
|
||||
[not-required not-required]
|
||||
[defaults defaults])
|
||||
(if (not (pair? not-required))
|
||||
(list `(,(append required not-required) ,@body))
|
||||
(cons `(,required
|
||||
,(cons f (append required
|
||||
(list (car defaults)))))
|
||||
(loop (append required (list (car not-required)))
|
||||
(cdr not-required)
|
||||
(cdr defaults))))))])
|
||||
,f))))
|
||||
|
||||
|
||||
(define send*
|
||||
(lambda (x . rest)
|
||||
(let ([g (gensym "send*")])
|
||||
`(let ([,g ,x])
|
||||
,@(map (lambda (x) `(send ,g ,@x))
|
||||
rest)))))
|
||||
|
||||
;; Another let-like form.
|
||||
(define local
|
||||
(lambda (defines expr1 . body)
|
||||
(unless (list? defines)
|
||||
(raise-syntax-error
|
||||
'local
|
||||
"bad definition sequence"
|
||||
(list* 'local defines expr1 body)
|
||||
defines))
|
||||
(let* ([symilist? (lambda (l)
|
||||
(let loop ([l l])
|
||||
(or (null? l)
|
||||
(symbol? l)
|
||||
(and (pair? l)
|
||||
(symbol? (car l))
|
||||
(loop (cdr l))))))]
|
||||
[defs
|
||||
(map
|
||||
(lambda (def)
|
||||
(unless (and (list? def)
|
||||
(pair? def)
|
||||
(case (car def)
|
||||
[(#%define-values define-values)
|
||||
(and (= 3 (length def))
|
||||
(list? (cadr def))
|
||||
(andmap symbol? (cadr def))
|
||||
(let-values ([(d kind) (local-expand-body-expression `(,(car def) (,(gensym)) 1))])
|
||||
(eq? kind '#%define-values)))]
|
||||
[(#%define define)
|
||||
(and (or (and (= 3 (length def))
|
||||
(symbol? (cadr def)))
|
||||
(and (<= 3 (length def))
|
||||
(pair? (cadr def))
|
||||
(symilist? (cadr def))))
|
||||
(let-values ([(d kind) (local-expand-body-expression `(,(car def) ,(gensym) 1))])
|
||||
(eq? kind '#%define-values)))]
|
||||
[(#%define-struct define-struct)
|
||||
(and (= 3 (length def))
|
||||
(or (symbol? (cadr def))
|
||||
(and (list? (cadr def))
|
||||
(= 2 (length (cadr def)))
|
||||
(symbol? (caadr def))))
|
||||
(list? (caddr def))
|
||||
(andmap symbol? (caddr def))
|
||||
(let-values ([(d kind) (local-expand-body-expression `(,(car def) ,(gensym) ()))])
|
||||
(eq? kind '#%define-values)))]
|
||||
[else #f]))
|
||||
(raise-syntax-error
|
||||
'local
|
||||
"bad definition"
|
||||
(list* 'local defines expr1 body)
|
||||
def))
|
||||
(case (car def)
|
||||
[(#%define-values define-values) (cadr def)]
|
||||
[(#%define define) (list (if (symbol? (cadr def))
|
||||
(cadr def)
|
||||
(caadr def)))]
|
||||
[else (let ([s `(#%define-struct
|
||||
,(if (symbol? (cadr def))
|
||||
(cadr def)
|
||||
(caadr def))
|
||||
,(caddr def))])
|
||||
(cadr (expand-defmacro s)))]))
|
||||
defines)]
|
||||
[defined-names (apply append defs)])
|
||||
; We wrap everything in an extra `let' to permit the shadowing
|
||||
; of syntax by local definitions:
|
||||
`(let ,(map (lambda (n) `(,n (#%void))) defined-names)
|
||||
; We have to use #% forms for define, now:
|
||||
,@(map (lambda (def)
|
||||
(case (car def)
|
||||
[(#%define-values define-values)
|
||||
(cons '#%define-values (cdr def))]
|
||||
[(#%define define)
|
||||
(cons '#%define (cdr def))]
|
||||
[(#%define-struct define-struct)
|
||||
(cons '#%define-struct (cdr def))]))
|
||||
defines)
|
||||
; Another let, in case there were more embedded defines:
|
||||
(let () ,expr1 ,@body)))))
|
||||
|
||||
;; recur is another name for 'let' in a named let
|
||||
(define recur
|
||||
(lambda (name args . body) `(let ,name ,args ,@body)))
|
||||
|
||||
;; define a recursive value
|
||||
(define rec
|
||||
(lambda (x rest)
|
||||
(if (symbol? x)
|
||||
`(letrec ([,x ,rest])
|
||||
,x)
|
||||
(raise-syntax-error 'rec "identifier must be a symbol"
|
||||
(list 'rec x rest) x))))
|
||||
|
||||
(define evcase
|
||||
(lambda (v . tests-in)
|
||||
(let ([serror
|
||||
(lambda (msg at)
|
||||
(raise-syntax-error
|
||||
'evcase
|
||||
msg
|
||||
(list* 'evcase v tests-in)
|
||||
at))])
|
||||
(let ([gen (gensym "evcase")])
|
||||
`(let ([,gen ,v])
|
||||
(cond
|
||||
,@(let loop ([tests tests-in])
|
||||
(cond
|
||||
[(null? tests) `()]
|
||||
[(pair? tests)
|
||||
(let ([test-value (car tests)]
|
||||
[rest (cdr tests)])
|
||||
`(,(if (or (not (pair? test-value))
|
||||
(not (pair? (cdr test-value))))
|
||||
(serror
|
||||
"bad syntax (clause is not a test-value pair)"
|
||||
test-value)
|
||||
(let ([test (car test-value)]
|
||||
[body (cdr test-value)])
|
||||
(if (and (pair? body) (list? body))
|
||||
#t
|
||||
(serror
|
||||
"bad syntax (improper clause body)"
|
||||
body))
|
||||
(let ([condition
|
||||
(cond
|
||||
[(and (eq? test 'else)
|
||||
(not (local-expansion-time-bound? 'else)))
|
||||
(if (null? rest)
|
||||
'else
|
||||
(serror
|
||||
"bad syntax (`else' clause must be last)"
|
||||
test-value))]
|
||||
[else `(eqv? ,gen ,test)])])
|
||||
`(,condition
|
||||
(begin ,@body)))))
|
||||
.
|
||||
,(loop rest)))]
|
||||
[else (serror
|
||||
"bad syntax (body must contain a list of pairs)"
|
||||
tests)]))))))))
|
||||
|
||||
(define nor (lambda args `(#%not (#%or ,@args))))
|
||||
(define nand (lambda args `(#%not (#%and ,@args))))
|
||||
|
||||
(define signature->symbols
|
||||
(lambda (name)
|
||||
(unless (symbol? name)
|
||||
(raise-syntax-error 'signature->symbols
|
||||
"not an identifier"
|
||||
(list 'signature->symbols name)
|
||||
name))
|
||||
(let ([v (global-expansion-time-value name)])
|
||||
(letrec ([sig? (lambda (v)
|
||||
(and (vector? v)
|
||||
(andmap
|
||||
(lambda (s)
|
||||
(or (and (pair? s)
|
||||
(symbol? (car s))
|
||||
(sig? (cdr s)))
|
||||
(symbol? s)))
|
||||
(vector->list v))))])
|
||||
(unless (sig? v)
|
||||
(raise-syntax-error 'signature->symbols
|
||||
"expansion-time value is not a signature"
|
||||
(list 'signature->symbols name)
|
||||
name))
|
||||
v)))))
|
||||
18
collects/mzlib/macrox.ss
Normal file
18
collects/mzlib/macrox.ss
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
|
||||
(begin-elaboration-time
|
||||
(require-library "refer.ss"))
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(begin-elaboration-time
|
||||
(define-values/invoke-unit (send*
|
||||
local
|
||||
recur
|
||||
rec
|
||||
evcase
|
||||
nor
|
||||
nand
|
||||
signature->symbols)
|
||||
(require-library "macroxr.ss")))
|
||||
|
||||
187
collects/mzlib/macroxr.ss
Normal file
187
collects/mzlib/macroxr.ss
Normal file
|
|
@ -0,0 +1,187 @@
|
|||
|
||||
(unit
|
||||
(import)
|
||||
(export send*
|
||||
local
|
||||
recur
|
||||
rec
|
||||
evcase
|
||||
nor
|
||||
nand
|
||||
signature->symbols)
|
||||
|
||||
(define send*
|
||||
(lambda (x . rest)
|
||||
(let ([g (gensym "send*")])
|
||||
`(let ([,g ,x])
|
||||
,@(map (lambda (x) `(send ,g ,@x))
|
||||
rest)))))
|
||||
|
||||
;; Another let-like form.
|
||||
(define local
|
||||
(lambda (defines expr1 . body)
|
||||
(unless (list? defines)
|
||||
(raise-syntax-error
|
||||
'local
|
||||
"bad definition sequence"
|
||||
(list* 'local defines expr1 body)
|
||||
defines))
|
||||
(let* ([symilist? (lambda (l)
|
||||
(let loop ([l l])
|
||||
(or (null? l)
|
||||
(symbol? l)
|
||||
(and (pair? l)
|
||||
(symbol? (car l))
|
||||
(loop (cdr l))))))]
|
||||
[defs
|
||||
(map
|
||||
(lambda (def)
|
||||
(unless (and (list? def)
|
||||
(pair? def)
|
||||
(case (car def)
|
||||
[(#%define-values define-values)
|
||||
(and (= 3 (length def))
|
||||
(list? (cadr def))
|
||||
(andmap symbol? (cadr def))
|
||||
(let-values ([(d kind) (local-expand-body-expression `(,(car def) (,(gensym)) 1))])
|
||||
(eq? kind '#%define-values)))]
|
||||
[(#%define define)
|
||||
(and (or (and (= 3 (length def))
|
||||
(symbol? (cadr def)))
|
||||
(and (<= 3 (length def))
|
||||
(pair? (cadr def))
|
||||
(symilist? (cadr def))))
|
||||
(let-values ([(d kind) (local-expand-body-expression `(,(car def) ,(gensym) 1))])
|
||||
(eq? kind '#%define-values)))]
|
||||
[(#%define-struct define-struct)
|
||||
(and (= 3 (length def))
|
||||
(or (symbol? (cadr def))
|
||||
(and (list? (cadr def))
|
||||
(= 2 (length (cadr def)))
|
||||
(symbol? (caadr def))))
|
||||
(list? (caddr def))
|
||||
(andmap symbol? (caddr def))
|
||||
(let-values ([(d kind) (local-expand-body-expression `(,(car def) ,(gensym) ()))])
|
||||
(eq? kind '#%define-values)))]
|
||||
[else #f]))
|
||||
(raise-syntax-error
|
||||
'local
|
||||
"bad definition"
|
||||
(list* 'local defines expr1 body)
|
||||
def))
|
||||
(case (car def)
|
||||
[(#%define-values define-values) (cadr def)]
|
||||
[(#%define define) (list (if (symbol? (cadr def))
|
||||
(cadr def)
|
||||
(caadr def)))]
|
||||
[else (let ([s `(#%define-struct
|
||||
,(if (symbol? (cadr def))
|
||||
(cadr def)
|
||||
(caadr def))
|
||||
,(caddr def))])
|
||||
(cadr (expand-defmacro s)))]))
|
||||
defines)]
|
||||
[defined-names (apply append defs)])
|
||||
; We wrap everything in an extra `let' to permit the shadowing
|
||||
; of syntax by local definitions:
|
||||
`(let ,(map (lambda (n) `(,n (#%void))) defined-names)
|
||||
; We have to use #% forms for define, now:
|
||||
,@(map (lambda (def)
|
||||
(case (car def)
|
||||
[(#%define-values define-values)
|
||||
(cons '#%define-values (cdr def))]
|
||||
[(#%define define)
|
||||
(cons '#%define (cdr def))]
|
||||
[(#%define-struct define-struct)
|
||||
(cons '#%define-struct (cdr def))]))
|
||||
defines)
|
||||
; Another let, in case there were more embedded defines:
|
||||
(let () ,expr1 ,@body)))))
|
||||
|
||||
;; recur is another name for 'let' in a named let
|
||||
(define recur
|
||||
(lambda (name args . body) `(let ,name ,args ,@body)))
|
||||
|
||||
;; define a recursive value
|
||||
(define rec
|
||||
(lambda (x rest)
|
||||
(if (symbol? x)
|
||||
`(letrec ([,x ,rest])
|
||||
,x)
|
||||
(raise-syntax-error 'rec "identifier must be a symbol"
|
||||
(list 'rec x rest) x))))
|
||||
|
||||
(define evcase
|
||||
(lambda (v . tests-in)
|
||||
(let ([serror
|
||||
(lambda (msg at)
|
||||
(raise-syntax-error
|
||||
'evcase
|
||||
msg
|
||||
(list* 'evcase v tests-in)
|
||||
at))])
|
||||
(let ([gen (gensym "evcase")])
|
||||
`(let ([,gen ,v])
|
||||
(cond
|
||||
,@(let loop ([tests tests-in])
|
||||
(cond
|
||||
[(null? tests) `()]
|
||||
[(pair? tests)
|
||||
(let ([test-value (car tests)]
|
||||
[rest (cdr tests)])
|
||||
`(,(if (or (not (pair? test-value))
|
||||
(not (pair? (cdr test-value))))
|
||||
(serror
|
||||
"bad syntax (clause is not a test-value pair)"
|
||||
test-value)
|
||||
(let ([test (car test-value)]
|
||||
[body (cdr test-value)])
|
||||
(if (and (pair? body) (list? body))
|
||||
#t
|
||||
(serror
|
||||
"bad syntax (improper clause body)"
|
||||
body))
|
||||
(let ([condition
|
||||
(cond
|
||||
[(and (eq? test 'else)
|
||||
(not (local-expansion-time-bound? 'else)))
|
||||
(if (null? rest)
|
||||
'else
|
||||
(serror
|
||||
"bad syntax (`else' clause must be last)"
|
||||
test-value))]
|
||||
[else `(eqv? ,gen ,test)])])
|
||||
`(,condition
|
||||
(begin ,@body)))))
|
||||
.
|
||||
,(loop rest)))]
|
||||
[else (serror
|
||||
"bad syntax (body must contain a list of pairs)"
|
||||
tests)]))))))))
|
||||
|
||||
(define nor (lambda args `(#%not (#%or ,@args))))
|
||||
(define nand (lambda args `(#%not (#%and ,@args))))
|
||||
|
||||
(define signature->symbols
|
||||
(lambda (name)
|
||||
(unless (symbol? name)
|
||||
(raise-syntax-error 'signature->symbols
|
||||
"not an identifier"
|
||||
(list 'signature->symbols name)
|
||||
name))
|
||||
(let ([v (global-expansion-time-value name)])
|
||||
(letrec ([sig? (lambda (v)
|
||||
(and (vector? v)
|
||||
(andmap
|
||||
(lambda (s)
|
||||
(or (and (pair? s)
|
||||
(symbol? (car s))
|
||||
(sig? (cdr s)))
|
||||
(symbol? s)))
|
||||
(vector->list v))))])
|
||||
(unless (sig? v)
|
||||
(raise-syntax-error 'signature->symbols
|
||||
"expansion-time value is not a signature"
|
||||
(list 'signature->symbols name)
|
||||
name))
|
||||
v)))))
|
||||
17
collects/mzlib/match.ss
Normal file
17
collects/mzlib/match.ss
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(begin-elaboration-time
|
||||
(define-values/invoke-unit (match:set-error
|
||||
match:set-error-control match:error-control-param
|
||||
match:error match match-lambda match-lambda*
|
||||
match-letrec match-let match-let*)
|
||||
(require-library "matchr.ss")))
|
||||
|
||||
(define-macro match match)
|
||||
(define-macro match-lambda match-lambda)
|
||||
(define-macro match-lambda* match-lambda*)
|
||||
(define-macro match-letrec match-letrec)
|
||||
(define-macro match-let match-let)
|
||||
(define-macro match-let* match-let*)
|
||||
1936
collects/mzlib/matchr.ss
Normal file
1936
collects/mzlib/matchr.ss
Normal file
File diff suppressed because it is too large
Load Diff
8
collects/mzlib/math.ss
Normal file
8
collects/mzlib/math.ss
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
|
||||
(require-library "mathu.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:math^
|
||||
mzlib:math@)
|
||||
39
collects/mzlib/mathr.ss
Normal file
39
collects/mzlib/mathr.ss
Normal file
|
|
@ -0,0 +1,39 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; math.ss: some extra math routines
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(unit/sig mzlib:math^
|
||||
(import)
|
||||
|
||||
;; circular constants and aliases
|
||||
(define e (exp 1.0))
|
||||
(define pi (atan 0 -1))
|
||||
|
||||
;; sgn function
|
||||
(define sgn
|
||||
(lambda (x)
|
||||
(cond
|
||||
((< x 0) -1)
|
||||
((> x 0) 1)
|
||||
(else 0))))
|
||||
|
||||
;; complex conjugate
|
||||
(define conjugate
|
||||
(lambda (z)
|
||||
(make-rectangular
|
||||
(real-part z)
|
||||
(- (imag-part z)))))
|
||||
|
||||
;; real hyperbolic functions
|
||||
(define sinh
|
||||
(lambda (x)
|
||||
(/
|
||||
(- (exp x) (exp (- x)))
|
||||
2.0)))
|
||||
|
||||
(define cosh
|
||||
(lambda (x)
|
||||
(/
|
||||
(+ (exp x) (exp (- x)))
|
||||
2.0))))
|
||||
7
collects/mzlib/maths.ss
Normal file
7
collects/mzlib/maths.ss
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
|
||||
(define-signature mzlib:math^
|
||||
(e
|
||||
pi
|
||||
sgn conjugate
|
||||
sinh cosh))
|
||||
|
||||
7
collects/mzlib/mathu.ss
Normal file
7
collects/mzlib/mathu.ss
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
|
||||
(require-library "maths.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "refer.ss"))
|
||||
|
||||
(define mzlib:math@ (require-library-unit/sig "mathr.ss"))
|
||||
12
collects/mzlib/mzlib.ss
Normal file
12
collects/mzlib/mzlib.ss
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
|
||||
; Load all of mzlib
|
||||
|
||||
(require-library "core.ss")
|
||||
|
||||
(require-library "compat.ss")
|
||||
(require-library "pconvert.ss")
|
||||
(require-library "date.ss")
|
||||
(require-library "inflate.ss")
|
||||
(require-library "cmdline.ss")
|
||||
(require-library "restart.ss")
|
||||
(require-library "transcr.ss")
|
||||
25
collects/mzlib/mzlibflatr.ss
Normal file
25
collects/mzlib/mzlibflatr.ss
Normal file
|
|
@ -0,0 +1,25 @@
|
|||
(compound-unit/sig
|
||||
(import)
|
||||
(link [core : mzlib:core-flat^ ((require-library-unit/sig "coreflatr.ss"))]
|
||||
[compat : mzlib:compat^ ((require-library-unit/sig "compatr.ss") (core : mzlib:function^))]
|
||||
[convert : mzlib:print-convert^
|
||||
((require-library-unit/sig "pconverr.ss")
|
||||
(core : mzlib:string^)
|
||||
(core : mzlib:function^))]
|
||||
[date : mzlib:date^ ((require-library-unit/sig "dater.ss")
|
||||
(core : mzlib:function^))]
|
||||
[inflate : mzlib:inflate^ ((require-library-unit/sig "inflater.ss"))]
|
||||
[command-line : mzlib:command-line^ ((require-library-unit/sig "cmdliner.ss"))]
|
||||
[restart : mzlib:restart^ ((require-library-unit/sig "restartr.ss")
|
||||
command-line)]
|
||||
[transcript : mzlib:transcript^ ((require-library-unit/sig "transcrr.ss"))])
|
||||
(export (open core)
|
||||
(open compat)
|
||||
(open convert)
|
||||
(open date)
|
||||
(open inflate)
|
||||
(open command-line)
|
||||
(open restart)
|
||||
(open transcript)))
|
||||
|
||||
|
||||
14
collects/mzlib/mzlibflats.ss
Normal file
14
collects/mzlib/mzlibflats.ss
Normal file
|
|
@ -0,0 +1,14 @@
|
|||
|
||||
(require-library "mzlibs.ss")
|
||||
|
||||
(require-library "coreflats.ss")
|
||||
|
||||
(define-signature mzlib:flat^
|
||||
((open mzlib:core^)
|
||||
(open mzlib:compat^)
|
||||
(open mzlib:print-convert^)
|
||||
(open mzlib:date^)
|
||||
(open mzlib:inflate^)
|
||||
(open mzlib:command-line^)
|
||||
(open mzlib:restart^)
|
||||
(open mzlib:transcript^)))
|
||||
4
collects/mzlib/mzlibm.ss
Normal file
4
collects/mzlib/mzlibm.ss
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
|
||||
(require-library "corem.ss")
|
||||
|
||||
(require-library "synrule.ss")
|
||||
25
collects/mzlib/mzlibr.ss
Normal file
25
collects/mzlib/mzlibr.ss
Normal file
|
|
@ -0,0 +1,25 @@
|
|||
(compound-unit/sig
|
||||
(import)
|
||||
(link [core : mzlib:core^ ((require-library-unit/sig "corer.ss"))]
|
||||
[compat : mzlib:compat^ ((require-library-unit/sig "compatr.ss") (core function))]
|
||||
[convert : mzlib:print-convert^
|
||||
((require-library-unit/sig "pconverr.ss")
|
||||
(core string)
|
||||
(core function))]
|
||||
[date : mzlib:date^ ((require-library-unit/sig "dater.ss")
|
||||
(core function))]
|
||||
[inflate : mzlib:inflate^ ((require-library-unit/sig "inflater.ss"))]
|
||||
[command-line : mzlib:command-line^ ((require-library-unit/sig "cmdliner.ss"))]
|
||||
[restart : mzlib:restart^ ((require-library-unit/sig "restartr.ss")
|
||||
command-line)]
|
||||
[transcript : mzlib:transcript^ ((require-library-unit/sig "transcrr.ss"))])
|
||||
(export (open core)
|
||||
(open compat)
|
||||
(unit convert)
|
||||
(unit date)
|
||||
(unit inflate)
|
||||
(unit command-line)
|
||||
(unit restart)
|
||||
(unit transcript)))
|
||||
|
||||
|
||||
20
collects/mzlib/mzlibs.ss
Normal file
20
collects/mzlib/mzlibs.ss
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
|
||||
(begin-elaboration-time
|
||||
(require-library "cores.ss")
|
||||
(require-library "compats.ss")
|
||||
(require-library "pconvers.ss")
|
||||
(require-library "dates.ss")
|
||||
(require-library "inflates.ss")
|
||||
(require-library "cmdlines.ss")
|
||||
(require-library "restarts.ss")
|
||||
(require-library "transcrs.ss"))
|
||||
|
||||
(define-signature mzlib^
|
||||
((open mzlib:core^)
|
||||
(unit compat : mzlib:compat^)
|
||||
(unit print-convert : mzlib:print-convert^)
|
||||
(unit date : mzlib:date^)
|
||||
(unit inflate : mzlib:inflate^)
|
||||
(unit command-line : mzlib:command-line^)
|
||||
(unit restart : mzlib:restart^)
|
||||
(unit transcript : mzlib:transcript^)))
|
||||
21
collects/mzlib/mzlibu.ss
Normal file
21
collects/mzlib/mzlibu.ss
Normal file
|
|
@ -0,0 +1,21 @@
|
|||
|
||||
; Load all of mzlib
|
||||
|
||||
(require-library "coreu.ss")
|
||||
|
||||
(require-library "synrule.ss")
|
||||
|
||||
(require-library "spidey.ss")
|
||||
(require-library "pconveru.ss")
|
||||
(require-library "dateu.ss")
|
||||
(require-library "inflateu.ss")
|
||||
(require-library "cmdlineu.ss")
|
||||
(require-library "restartu.ss")
|
||||
(require-library "transcru.ss")
|
||||
|
||||
(require-library "mzlibs.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "refer.ss"))
|
||||
|
||||
(define mzlib@ (require-library-unit/sig "mzlibr.ss"))
|
||||
13
collects/mzlib/pconver.ss
Normal file
13
collects/mzlib/pconver.ss
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
|
||||
(require-library "pconveru.ss")
|
||||
(require-library "string.ss")
|
||||
(require-library "functio.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:print-convert^
|
||||
mzlib:print-convert@
|
||||
#f
|
||||
mzlib:string^
|
||||
mzlib:function^)
|
||||
438
collects/mzlib/pconverr.ss
Normal file
438
collects/mzlib/pconverr.ss
Normal file
|
|
@ -0,0 +1,438 @@
|
|||
(unit/sig mzlib:print-convert^
|
||||
(import (s : mzlib:string^)
|
||||
(f : mzlib:function^))
|
||||
|
||||
(define undefined-val (letrec ([x x]) x))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; the value stored in the hash table. Contains the name
|
||||
;; <which is a number unless we are in donkey and it already has a name>
|
||||
;; and whether or not it is shared in the expr.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define-struct share-info (name shared?))
|
||||
|
||||
(define boolean-filter (lambda (x) (and x #t)))
|
||||
|
||||
(define show-sharing (make-parameter #t boolean-filter))
|
||||
(define constructor-style-printing (make-parameter #f boolean-filter))
|
||||
(define quasi-read-style-printing (make-parameter #t boolean-filter))
|
||||
(define abbreviate-cons-as-list (make-parameter #t boolean-filter))
|
||||
(define whole/fractional-exact-numbers (make-parameter #t boolean-filter))
|
||||
(define booleans-as-true/false (make-parameter #t boolean-filter))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; share-hash is the hash-table containing info on what cons cells
|
||||
;; of the expression are shared.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; sometimes you want to go ahead and start displaying a shared
|
||||
;; expression rather than just showing its name. For instance, in
|
||||
;; the shared list, you want (shared ((-1- (list 1 2))... not
|
||||
;; (shared ((-1- -1-) ...
|
||||
;; expand-shared? controls this
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define-struct convert-share-info (share-hash expand-shared?))
|
||||
|
||||
(define current-build-share-name-hook (make-parameter (lambda (e) #f)
|
||||
(lambda (f)
|
||||
(unless (procedure-arity-includes? f 1)
|
||||
(raise-type-error 'current-build-share-name-hook "procedure of arity 1" f))
|
||||
f)))
|
||||
(define current-build-share-hook (make-parameter (lambda (e base sub) (base e))
|
||||
(lambda (f)
|
||||
(unless (procedure-arity-includes? f 3)
|
||||
(raise-type-error 'current-build-share-hook "procedure of arity 3" f))
|
||||
f)))
|
||||
(define current-print-convert-hook (make-parameter (lambda (e base sub) (base e))
|
||||
(lambda (f)
|
||||
(unless (procedure-arity-includes? f 3)
|
||||
(raise-type-error 'current--hook "procedure of arity 3" f))
|
||||
f)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; builds the hash table
|
||||
;; --------- THIS PROCEDURE IS EXPORTED ----------
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define build-share
|
||||
(lambda (expr)
|
||||
(letrec
|
||||
([share-cnt 0]
|
||||
[share-hash (make-hash-table)]
|
||||
[csi (make-convert-share-info share-hash #f)]
|
||||
[hash
|
||||
(lambda (obj)
|
||||
(let ([name ((current-build-share-name-hook) obj)])
|
||||
(hash-table-put! share-hash obj
|
||||
(make-share-info (if name (car name) share-cnt) #f)))
|
||||
(set! share-cnt (add1 share-cnt)))]
|
||||
[build-sub
|
||||
(lambda (expr)
|
||||
(let/ec k
|
||||
(let ([val (hash-table-get share-hash expr
|
||||
(lambda () (hash expr) (k #f)))])
|
||||
(when val
|
||||
(set-share-info-shared?! val #t))
|
||||
val)))]
|
||||
[build
|
||||
(lambda (expr)
|
||||
((current-build-share-hook)
|
||||
expr
|
||||
(lambda (expr)
|
||||
(cond
|
||||
[(or (number? expr)
|
||||
(symbol? expr)
|
||||
(boolean? expr)
|
||||
(char? expr) (void? expr)
|
||||
(null? expr)
|
||||
(eq? expr undefined-val) ; #<undefined> test - yuck
|
||||
; (regexp? expr)
|
||||
; (port? expr)
|
||||
; (promise? expr)
|
||||
; (object? expr) (class? expr) (interface? exp)
|
||||
; (unit? expr)
|
||||
; (procedure? expr)
|
||||
)
|
||||
'atomic]
|
||||
[(inferred-name expr) 'atomic]
|
||||
[(box? expr) (unless (build-sub expr)
|
||||
(build (unbox expr)))]
|
||||
[(hash-table? expr) (unless (build-sub expr)
|
||||
(hash-table-for-each
|
||||
expr
|
||||
(lambda (key value)
|
||||
(build value))))]
|
||||
[(pair? expr) (unless (build-sub expr)
|
||||
(build (car expr))
|
||||
(build (cdr expr)))]
|
||||
[(vector? expr) (unless (build-sub expr)
|
||||
(for-each build (vector->list expr)))]
|
||||
[(struct? expr) (unless (build-sub expr)
|
||||
(for-each build (vector->list (struct->vector expr))))]
|
||||
[else (build-sub expr)]))
|
||||
build-sub))])
|
||||
(build expr)
|
||||
csi)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; creates a distinctive symbol out of a name (usually just a number)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define map-share-name
|
||||
(lambda (name)
|
||||
(string->symbol
|
||||
(string-append "-" (s:expr->string name) "-"))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; prints an expression given that it has already been hashed. This
|
||||
;; does not include the list of shared items.
|
||||
;; --------- THIS PROCEDURE IS EXPORTED ----------
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define print-convert-expr
|
||||
(lambda (csi expr unroll-once?)
|
||||
(letrec
|
||||
([share-hash (convert-share-info-share-hash csi)]
|
||||
[find-hash
|
||||
(lambda (expr)
|
||||
(hash-table-get share-hash expr (lambda () #f)))]
|
||||
[shared?
|
||||
(lambda (expr)
|
||||
(let* ([info (find-hash expr)]
|
||||
[ans (and info
|
||||
(share-info-shared? info))])
|
||||
ans))]
|
||||
[make-list
|
||||
(lambda (f n)
|
||||
(letrec ([helper
|
||||
(lambda (n l)
|
||||
(cond [(zero? n) l]
|
||||
[else (helper (sub1 n) (cons (f n) l))]))])
|
||||
(helper n null)))]
|
||||
[make-lambda-helper
|
||||
(lambda (arity)
|
||||
(cond
|
||||
[(arity-at-least? arity)
|
||||
(let ([v (arity-at-least-value arity)])
|
||||
(if (zero? v)
|
||||
'args
|
||||
(append (make-lambda-helper v) 'args)))]
|
||||
[(list? arity)
|
||||
(map (lambda (x)
|
||||
(list (make-lambda-helper x) '...))
|
||||
arity)]
|
||||
[else (make-list
|
||||
(lambda (x)
|
||||
(string->symbol
|
||||
(string-append "a" (number->string x))))
|
||||
arity)]))]
|
||||
[use-quasi-quote? (not (constructor-style-printing))]
|
||||
[use-read-syntax (quasi-read-style-printing)]
|
||||
[doesnt-contain-shared-conses
|
||||
(lambda (input-expr)
|
||||
(letrec ([doesnt-contain-shared-conses
|
||||
(lambda (expr)
|
||||
(cond
|
||||
[(and (pair? expr)
|
||||
(shared? expr))
|
||||
#f]
|
||||
[(pair? expr)
|
||||
(doesnt-contain-shared-conses (cdr expr))]
|
||||
[else #t]))])
|
||||
(let ([answer (doesnt-contain-shared-conses input-expr)])
|
||||
answer)))]
|
||||
[get-whole/frac
|
||||
(lambda (exact-num)
|
||||
(let ([split
|
||||
(lambda (real)
|
||||
(let* ([num (numerator real)]
|
||||
[den (denominator real)])
|
||||
(values (quotient num den)
|
||||
(* (if (negative? num) -1 1)
|
||||
(/ (modulo num den) den)))))])
|
||||
(let-values ([(whole frac) (split (real-part exact-num))]
|
||||
[(whole-i frac-i) (split (imag-part exact-num))])
|
||||
(values whole frac whole-i frac-i))))]
|
||||
[print
|
||||
(lambda (in-quasiquote? first-time)
|
||||
(lambda (expr)
|
||||
(letrec
|
||||
([lookup (find-hash expr)]
|
||||
[recur (print in-quasiquote? #f)]
|
||||
[self-quoting?
|
||||
(lambda (expr)
|
||||
(or (and (number? expr)
|
||||
(or (inexact? expr)
|
||||
(not (whole/fractional-exact-numbers))
|
||||
(and (real? expr)
|
||||
(or (let-values ([(whole frac whole-i frac-i) (get-whole/frac expr)])
|
||||
(and (or (zero? whole)
|
||||
(zero? frac))))))))
|
||||
(and (symbol? expr)
|
||||
(not (eq? expr 'quasiquote))
|
||||
(not (eq? expr 'quote))
|
||||
(not (eq? expr 'unquote)))
|
||||
(char? expr)
|
||||
(string? expr)
|
||||
(not expr)
|
||||
(eq? #t expr)))]
|
||||
[quasi-read-style
|
||||
(lambda ()
|
||||
(cond
|
||||
[(box? expr) (box (recur (unbox expr)))]
|
||||
[(vector? expr) (apply vector (map recur (vector->list expr)))]
|
||||
[else (quasi-style)]))]
|
||||
[quasi-style
|
||||
(lambda ()
|
||||
(cond
|
||||
[(null? expr) '()]
|
||||
[(and (list? expr)
|
||||
(doesnt-contain-shared-conses expr))
|
||||
(map recur expr)]
|
||||
[(pair? expr)
|
||||
(cons (recur (car expr)) (recur (cdr expr)))]
|
||||
[(self-quoting? expr) expr]
|
||||
[else `(,'unquote ,((print #f first-time) expr))]))]
|
||||
[guard
|
||||
(lambda (f)
|
||||
(cond
|
||||
[use-quasi-quote?
|
||||
`(,'quasiquote ,(if use-read-syntax
|
||||
((print #t first-time) expr)
|
||||
((print #t first-time) expr)))]
|
||||
[else
|
||||
(f)]))]
|
||||
[constructor-style
|
||||
(let* ([build-named
|
||||
(lambda (expr build-unnamed)
|
||||
(let ([answer (inferred-name expr)])
|
||||
(if answer
|
||||
(if (eq? (with-handlers ([(lambda (x) #t)
|
||||
(lambda (x) #f)])
|
||||
(global-defined-value answer))
|
||||
expr)
|
||||
answer
|
||||
(build-unnamed))
|
||||
(build-unnamed))))])
|
||||
(lambda ()
|
||||
((current-print-convert-hook)
|
||||
expr
|
||||
(lambda (expr)
|
||||
(cond
|
||||
[(null? expr) (guard (lambda () 'empty))]
|
||||
[(and (list? expr)
|
||||
(abbreviate-cons-as-list)
|
||||
(or (and first-time
|
||||
(doesnt-contain-shared-conses (cdr expr)))
|
||||
(doesnt-contain-shared-conses expr)))
|
||||
(guard (lambda ()
|
||||
`(list ,@(map recur expr))))]
|
||||
[(pair? expr)
|
||||
(guard
|
||||
(lambda ()
|
||||
`(cons ,(recur (car expr)) ,(recur (cdr expr)))))]
|
||||
[(weak-box? expr) `(make-weak-box ,(recur (weak-box-value expr)))]
|
||||
[(box? expr) `(box ,(recur (unbox expr)))]
|
||||
[(hash-table? expr) `(make-hash-table)]
|
||||
[(vector? expr) `(vector ,@(map recur (vector->list expr)))]
|
||||
[(symbol? expr) `',expr]
|
||||
[(string? expr) expr]
|
||||
[(primitive? expr) (string->symbol (primitive-name expr))]
|
||||
[(procedure? expr)
|
||||
(build-named
|
||||
expr
|
||||
(lambda ()
|
||||
(let ([arity (arity expr)])
|
||||
(if (list? arity)
|
||||
`(case-lambda . ,(make-lambda-helper arity))
|
||||
`(lambda ,(make-lambda-helper arity) ...)))))]
|
||||
[(regexp? expr) `(regexp ...)]
|
||||
[(interface? expr) `(interface ...)]
|
||||
[(class? expr)
|
||||
(build-named
|
||||
expr
|
||||
(lambda () '(class ...)))]
|
||||
[(object? expr) `(make-object
|
||||
,(build-named
|
||||
(object-interface expr)
|
||||
(lambda () '(class ...)))
|
||||
...)]
|
||||
[(void? expr) '(void)]
|
||||
[(promise? expr) '(delay ...)]
|
||||
[(struct? expr)
|
||||
(let ([name (symbol->string
|
||||
(vector-ref (struct->vector expr) 0))])
|
||||
(cons (string->symbol
|
||||
(string-append
|
||||
"make-" (substring name
|
||||
(string-length "struct:")
|
||||
(string-length name))))
|
||||
(map recur (cdr (vector->list
|
||||
(struct->vector expr))))))]
|
||||
[(unit? expr) (build-named
|
||||
expr
|
||||
(lambda ()
|
||||
'(unit ...)))]
|
||||
[(and (number? expr) (exact? expr))
|
||||
(let-values ([(whole frac whole-i frac-i) (get-whole/frac expr)])
|
||||
(cond
|
||||
[(not (whole/fractional-exact-numbers)) expr]
|
||||
[(and (or (zero? whole)
|
||||
(zero? frac))
|
||||
(zero? whole-i)
|
||||
(zero? frac-i))
|
||||
expr]
|
||||
[(real? expr) `(+ ,whole ,frac)]
|
||||
[(and (or (zero? whole) (zero? frac))
|
||||
(or (zero? whole-i) (zero? frac-i)))
|
||||
`(+ ,(real-part expr) (* +1i ,(imag-part expr)))]
|
||||
[(or (zero? whole-i) (zero? frac-i))
|
||||
`(+ (+ ,whole ,frac) (* +1i ,(imag-part expr)))]
|
||||
[(or (zero? whole) (zero? frac))
|
||||
`(+ ,(real-part expr) (* +1i (+ ,whole-i ,frac-i)))]
|
||||
[else `(+ (+ ,whole ,frac) (* +1i (+ ,whole-i ,frac-i)))]))]
|
||||
[(eq? expr #f) (if (booleans-as-true/false) 'false #f)]
|
||||
[(eq? expr #t) (if (booleans-as-true/false) 'true #t)]
|
||||
[else expr]))
|
||||
recur)))])
|
||||
(let ([es (convert-share-info-expand-shared? csi)])
|
||||
(set-convert-share-info-expand-shared?! csi #f)
|
||||
(if (and lookup
|
||||
(not es)
|
||||
(not first-time)
|
||||
(share-info-shared? lookup))
|
||||
(let ([name (map-share-name (share-info-name lookup))])
|
||||
(if in-quasiquote?
|
||||
`(,'unquote ,name)
|
||||
name))
|
||||
(if in-quasiquote?
|
||||
(if use-read-syntax
|
||||
(quasi-read-style)
|
||||
(quasi-style))
|
||||
(constructor-style)))))))])
|
||||
((print #f unroll-once?) expr))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; these functions get the list of shared items. If just-circular is
|
||||
;; true, then it will modify the hash table so that the only shared
|
||||
;; items are those that are circular.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define get-shared-helper
|
||||
(lambda (csi)
|
||||
(let ([shared '()]
|
||||
[share-hash (convert-share-info-share-hash csi)])
|
||||
(hash-table-for-each share-hash
|
||||
(lambda (key val)
|
||||
(when (share-info-shared? val)
|
||||
(set! shared (cons (list key val) shared)))))
|
||||
(map (lambda (s)
|
||||
(set-convert-share-info-expand-shared?! csi #t)
|
||||
(let* ([info (cadr s)]
|
||||
[name (share-info-name info)])
|
||||
(list info
|
||||
(map-share-name name)
|
||||
(print-convert-expr csi (car s) #t))))
|
||||
shared))))
|
||||
|
||||
;; --------- THIS PROCEDURE IS EXPORTED ----------
|
||||
(define get-shared
|
||||
(case-lambda
|
||||
[(csi) (get-shared csi #f)]
|
||||
[(csi just-circular)
|
||||
(let ([shared-listss
|
||||
(if just-circular
|
||||
(let ([shared (get-shared-helper csi)])
|
||||
(for-each (lambda (x)
|
||||
(unless (member* (cadr x) (caddr x))
|
||||
(set-share-info-shared?! (car x) #f)))
|
||||
shared)
|
||||
(get-shared-helper csi))
|
||||
(get-shared-helper csi))]
|
||||
[cmp
|
||||
(lambda (x y)
|
||||
(string<? (s:expr->string (share-info-name (car x)))
|
||||
(s:expr->string (share-info-name (car y)))))])
|
||||
(map cdr (f:quicksort shared-listss cmp)))]))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; helper function for determining if an item is circular. In the
|
||||
;; shared list: (shared ((-1- (list 1 2)) (-2- (list -2- 2 3)))), you
|
||||
;; can tell by doing a member* of the first item on the second. In this
|
||||
;; case, the second item in the shared list is circular because -2- appears
|
||||
;; in the value
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define member*
|
||||
(lambda (a l)
|
||||
(cond [(or (not (pair? l)) (null? l)) #f]
|
||||
[(eq? a (car l)) #t]
|
||||
[else (or (member* a (car l)) (member* a (cdr l)))])))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; takes an expression and completely converts it to show sharing
|
||||
;; (or if just-circular, just circularity) and special forms.
|
||||
;; --------- THIS PROCEDURE IS EXPORTED ----------
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define print-convert
|
||||
(case-lambda
|
||||
[(expr) (print-convert expr (not (show-sharing)))]
|
||||
[(expr just-circ)
|
||||
(let* ([csi (build-share expr)])
|
||||
(let ([shared (get-shared csi just-circ)]
|
||||
[body (print-convert-expr csi expr #f)])
|
||||
(if (null? shared)
|
||||
body
|
||||
`(shared ,shared ,body))))]))
|
||||
|
||||
(define current-read-eval-convert-print-prompt
|
||||
(make-parameter "|- "))
|
||||
|
||||
(define install-converting-printer
|
||||
(lambda ()
|
||||
(let ([print (current-print)])
|
||||
(current-print (lambda (v)
|
||||
(unless (void? v)
|
||||
(print (print-convert v))))))
|
||||
(current-prompt-read (lambda ()
|
||||
(display (current-read-eval-convert-print-prompt))
|
||||
(read))))))
|
||||
|
||||
;; TEST SUITE MOVED to mzscheme command test suite area.
|
||||
;; plt/tests/mzscheme/pconvert.ss
|
||||
24
collects/mzlib/pconvers.ss
Normal file
24
collects/mzlib/pconvers.ss
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
|
||||
(begin-elaboration-time
|
||||
(require-library "strings.ss")
|
||||
(require-library "functios.ss"))
|
||||
|
||||
(define-signature mzlib:print-convert^
|
||||
(show-sharing
|
||||
constructor-style-printing
|
||||
quasi-read-style-printing
|
||||
abbreviate-cons-as-list
|
||||
whole/fractional-exact-numbers
|
||||
booleans-as-true/false
|
||||
|
||||
print-convert
|
||||
print-convert-expr
|
||||
build-share
|
||||
get-shared
|
||||
current-read-eval-convert-print-prompt
|
||||
install-converting-printer
|
||||
|
||||
current-build-share-name-hook
|
||||
current-build-share-hook
|
||||
current-print-convert-hook))
|
||||
|
||||
2
collects/mzlib/pconvert.ss
Normal file
2
collects/mzlib/pconvert.ss
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(require-library "pconver.ss")
|
||||
21
collects/mzlib/pconveru.ss
Normal file
21
collects/mzlib/pconveru.ss
Normal file
|
|
@ -0,0 +1,21 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Gann Bierner -=)
|
||||
;; gbierner@owlnet.rice.edu (=- \ O
|
||||
;; _O \_-)---
|
||||
;; File: pconveru.ss (=-_/ /\
|
||||
;; /\
|
||||
;;
|
||||
;; This file contains code which formats an expression to show all sharing
|
||||
;; within it. Call `print-convert' to convert a value.
|
||||
;; It takes 2 optional arguments. The first is a boolean value, just-circular.
|
||||
;; If true, sharing will only be shown for circularity. The default is #f
|
||||
;; where all sharing is shown. The first argument to share:print-all is, of
|
||||
;; course, the expression to convert.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(require-library "pconvers.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "refer.ss"))
|
||||
|
||||
(define mzlib:print-convert@ (require-library-unit/sig "pconverr.ss"))
|
||||
10
collects/mzlib/pretty.ss
Normal file
10
collects/mzlib/pretty.ss
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
|
||||
(require-library "prettyu.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:pretty-print^
|
||||
mzlib:pretty-print@)
|
||||
|
||||
|
||||
838
collects/mzlib/prettyr.ss
Normal file
838
collects/mzlib/prettyr.ss
Normal file
|
|
@ -0,0 +1,838 @@
|
|||
; Originally:
|
||||
;"genwrite.scm" generic write used by pp.scm
|
||||
;;copyright (c) 1991, marc feeley
|
||||
|
||||
; Pretty-printer for MzScheme
|
||||
; Handles structures, cycles, and graphs
|
||||
;
|
||||
; Procedures:
|
||||
;
|
||||
; (pretty-print v) - pretty-prints v (like `write')
|
||||
; (pretty-print v port) - pretty-prints v to port
|
||||
;
|
||||
; (pretty-display ...) - like pretty-print, but prints like `display'
|
||||
; instead of like `write'
|
||||
;
|
||||
; pretty-print-columns - parameter for the default number of columns
|
||||
; or 'infinity; initial setting: 79
|
||||
;
|
||||
; pretty-print-print-line - parameter of a procedure that prints
|
||||
; to separate each line; 0 indicate before the first line, #f after the
|
||||
; last line
|
||||
;
|
||||
; pretty-print-depth - parameter for the default print depth
|
||||
; initial setting: #f (= infinity)
|
||||
;
|
||||
; pretty-print-size-hook - parameter for the print size hook; returns #f to
|
||||
; let pretty-printer handle it, number otherwise
|
||||
; initial setting: (lambda (x display? port) #f)
|
||||
;
|
||||
; pretty-print-print-hook - parameter for the print hook, called when the
|
||||
; size-hook returns a non-#f value
|
||||
; initial setting: (lambda (x display? port) (void))
|
||||
;
|
||||
; pretty-print-display-string-handler - parameter for the string display
|
||||
; procedure, called to finally write text
|
||||
; to the port
|
||||
;
|
||||
; pretty-print-pre-print-hook - parameter for a procedure that is called
|
||||
; just before each object is printed
|
||||
; initial setting: (lambda (x port) (void))
|
||||
;
|
||||
; pretty-print-post-print-hook - parameter for a procedure that is called
|
||||
; just after each object is printed
|
||||
; initial setting: (lambda (x port) (void))
|
||||
;
|
||||
; pretty-print-show-inexactness - parameter for printing #i before an
|
||||
; inexact number
|
||||
; initial setting: #f
|
||||
;
|
||||
; pretty-print-exact-as-decimal - parameter for printing exact numbers
|
||||
; with decimal representations in decimal
|
||||
; notation instead of fractions
|
||||
; initial setting: #f
|
||||
;
|
||||
; (pretty-print-handler v) - pretty-prints v if v is not #<void>
|
||||
;
|
||||
; TO INSTALL this pretty-printer into a MzScheme's read-eval-print loop,
|
||||
; load this file and evaluate:
|
||||
; (current-print pretty-print-handler)
|
||||
|
||||
|
||||
;; Matthew's changes:
|
||||
;; Modified original for MrEd Spring/95
|
||||
;; Added check for cyclic structures 11/9/95
|
||||
;; Better (correct) graph printing, support boxes and structures 11/26/95
|
||||
;; Support for print depth 2/28/96
|
||||
;; functor 4/22/96
|
||||
;; unit/s 6/13/96
|
||||
;; size- and print-hook 8/22/96
|
||||
;; real parameters 9/27/96
|
||||
;; print-line parameter 8/18/97
|
||||
|
||||
(unit/sig
|
||||
mzlib:pretty-print^
|
||||
(import)
|
||||
|
||||
(define pretty-print-show-inexactness
|
||||
(make-parameter #f
|
||||
(lambda (x) (and x #t))))
|
||||
|
||||
(define pretty-print-exact-as-decimal
|
||||
(make-parameter #f
|
||||
(lambda (x) (and x #t))))
|
||||
|
||||
(define pretty-print-columns
|
||||
(make-parameter 79
|
||||
(lambda (x)
|
||||
(unless (or (eq? x 'infinity)
|
||||
(integer? x))
|
||||
(raise-type-error
|
||||
'pretty-print-columns
|
||||
"integer or 'infinity"
|
||||
x))
|
||||
x)))
|
||||
|
||||
(define pretty-print-depth
|
||||
(make-parameter #f
|
||||
(lambda (x)
|
||||
(unless (or (not x) (number? x))
|
||||
(raise-type-error
|
||||
'pretty-print-depth
|
||||
"number or #f"
|
||||
x))
|
||||
x)))
|
||||
|
||||
(define can-accept-n?
|
||||
(lambda (n x)
|
||||
(procedure-arity-includes? x n)))
|
||||
|
||||
(define pretty-print-size-hook
|
||||
(make-parameter (lambda (x display? port) #f)
|
||||
(lambda (x)
|
||||
(unless (can-accept-n? 3 x)
|
||||
(raise-type-error
|
||||
'pretty-print-size-hook
|
||||
"procedure of 3 arguments"
|
||||
x))
|
||||
x)))
|
||||
|
||||
(define pretty-print-print-hook
|
||||
(make-parameter void
|
||||
(lambda (x)
|
||||
(unless (can-accept-n? 3 x)
|
||||
(raise-type-error
|
||||
'pretty-print-print-hook
|
||||
"procedure of 3 arguments"
|
||||
x))
|
||||
x)))
|
||||
|
||||
(define pretty-print-display-string-handler
|
||||
(make-parameter (let ([dh (port-display-handler (open-output-string))])
|
||||
; dh is primitive port display handler
|
||||
dh)
|
||||
(lambda (x)
|
||||
(unless (can-accept-n? 2 x)
|
||||
(raise-type-error
|
||||
'pretty-print-display-string-handler
|
||||
"procedure of 2 arguments"
|
||||
x))
|
||||
x)))
|
||||
|
||||
(define pretty-print-print-line
|
||||
(make-parameter (lambda (line port offset width)
|
||||
(when (and (number? width)
|
||||
(not (eq? 0 line)))
|
||||
(newline port))
|
||||
0)
|
||||
(lambda (x)
|
||||
(unless (can-accept-n? 4 x)
|
||||
(raise-type-error
|
||||
'pretty-print-print-line
|
||||
"procedure of 4 arguments"
|
||||
x))
|
||||
x)))
|
||||
|
||||
(define pretty-print-pre-print-hook
|
||||
(make-parameter void
|
||||
(lambda (x)
|
||||
(unless (can-accept-n? 2 x)
|
||||
(raise-type-error
|
||||
'pretty-print-pre-print-hook
|
||||
"procedure of 2 arguments"
|
||||
x))
|
||||
x)))
|
||||
|
||||
(define pretty-print-post-print-hook
|
||||
(make-parameter void
|
||||
(lambda (x)
|
||||
(unless (can-accept-n? 2 x)
|
||||
(raise-type-error
|
||||
'pretty-print-post-print-hook
|
||||
"procedure of 2 arguments"
|
||||
x))
|
||||
x)))
|
||||
|
||||
(define make-pretty-print
|
||||
(lambda (display?)
|
||||
(letrec ([pretty-print
|
||||
(case-lambda
|
||||
[(obj port)
|
||||
(let ([width (pretty-print-columns)]
|
||||
[size-hook (pretty-print-size-hook)]
|
||||
[print-hook (pretty-print-print-hook)]
|
||||
[pre-hook (pretty-print-pre-print-hook)]
|
||||
[post-hook (pretty-print-post-print-hook)])
|
||||
(generic-write obj display?
|
||||
width
|
||||
(let ([display (pretty-print-display-string-handler)])
|
||||
(lambda (s)
|
||||
(display s port)
|
||||
#t))
|
||||
(lambda (s l)
|
||||
(print-hook s display? port)
|
||||
#t)
|
||||
(print-graph) (print-struct)
|
||||
(and (not display?) (print-vector-length))
|
||||
(pretty-print-depth)
|
||||
(lambda (o display?)
|
||||
(size-hook o display? port))
|
||||
(let ([print-line (pretty-print-print-line)])
|
||||
(lambda (line offset)
|
||||
(print-line line port offset width)))
|
||||
(lambda (obj)
|
||||
(pre-hook obj port))
|
||||
(lambda (obj)
|
||||
(post-hook obj port)))
|
||||
(void))]
|
||||
[(obj) (pretty-print obj (current-output-port))])])
|
||||
pretty-print)))
|
||||
|
||||
(define pretty-print (make-pretty-print #f))
|
||||
(define pretty-display (make-pretty-print #t))
|
||||
|
||||
(define (generic-write obj display? width output output-hooked
|
||||
print-graph? print-struct? print-vec-length?
|
||||
depth size-hook print-line
|
||||
pre-print post-print)
|
||||
|
||||
(define line-number 0)
|
||||
|
||||
(define table (make-hash-table)) ; Hash table for looking for loops
|
||||
|
||||
(define show-inexactness? (pretty-print-show-inexactness))
|
||||
(define exact-as-decimal? (pretty-print-exact-as-decimal))
|
||||
|
||||
(define-struct mark (str def))
|
||||
|
||||
(define found-cycle
|
||||
(or print-graph?
|
||||
(let loop ([obj obj])
|
||||
(and (or (vector? obj)
|
||||
(pair? obj)
|
||||
(box? obj)
|
||||
(and (struct? obj) print-struct?))
|
||||
(or (hash-table-get table obj (lambda () #f))
|
||||
(begin
|
||||
(hash-table-put! table obj #t)
|
||||
(let ([cycle
|
||||
(cond
|
||||
[(vector? obj)
|
||||
(ormap loop (vector->list obj))]
|
||||
[(pair? obj)
|
||||
(or (loop (car obj))
|
||||
(loop (cdr obj)))]
|
||||
[(box? obj) (loop (unbox obj))]
|
||||
[(struct? obj)
|
||||
(ormap loop
|
||||
(vector->list (struct->vector obj)))])])
|
||||
(hash-table-remove! table obj)
|
||||
cycle)))))))
|
||||
|
||||
(define :::dummy:::
|
||||
(if found-cycle
|
||||
(let loop ([obj obj])
|
||||
(if (or (vector? obj)
|
||||
(pair? obj)
|
||||
(box? obj)
|
||||
(and (struct? obj) print-struct?))
|
||||
; A little confusing: use #t for not-found
|
||||
(let ([p (hash-table-get table obj (lambda () #t))])
|
||||
(when (not (mark? p))
|
||||
(if p
|
||||
(begin
|
||||
(hash-table-put! table obj #f)
|
||||
(cond
|
||||
[(vector? obj)
|
||||
(loop (vector->list obj))]
|
||||
[(pair? obj)
|
||||
(loop (car obj))
|
||||
(loop (cdr obj))]
|
||||
[(box? obj) (loop (unbox obj))]
|
||||
[(struct? obj)
|
||||
(for-each loop
|
||||
(vector->list (struct->vector obj)))]))
|
||||
(begin
|
||||
(hash-table-put! table obj
|
||||
(make-mark #f (box #f)))))))))))
|
||||
|
||||
(define cycle-counter 0)
|
||||
|
||||
(define found (if found-cycle
|
||||
table
|
||||
#f))
|
||||
|
||||
(define dsub1 (lambda (d)
|
||||
(if d
|
||||
(sub1 d)
|
||||
#f)))
|
||||
|
||||
(print-line
|
||||
#f
|
||||
(let generic-write ([obj obj] [display? display?]
|
||||
[width width]
|
||||
[output output] [output-hooked output-hooked]
|
||||
[depth depth] [def-box (box #t)]
|
||||
[startpos (print-line 0 0)]
|
||||
[pre-print pre-print] [post-print post-print])
|
||||
|
||||
(define (read-macro? l)
|
||||
(define (length1? l) (and (pair? l) (null? (cdr l))))
|
||||
(let ((head (car l)) (tail (cdr l)))
|
||||
(case head
|
||||
((quote quasiquote unquote unquote-splicing) (length1? tail))
|
||||
(else #f))))
|
||||
|
||||
(define (read-macro-body l)
|
||||
(cadr l))
|
||||
|
||||
(define (read-macro-prefix l)
|
||||
(let ((head (car l)))
|
||||
(case head
|
||||
((quote) "'")
|
||||
((quasiquote) "`")
|
||||
((unquote) ",")
|
||||
((unquote-splicing) ",@"))))
|
||||
|
||||
(define (drop-repeated l)
|
||||
(if (null? l)
|
||||
null
|
||||
(let ([rest (drop-repeated (cdr l))])
|
||||
(cond
|
||||
[(and (pair? rest)
|
||||
(null? (cdr rest))
|
||||
(eq? (car l) (car rest)))
|
||||
rest]
|
||||
[(eq? rest (cdr l)) l]
|
||||
[else (cons (car l) rest)]))))
|
||||
|
||||
(define (out str col)
|
||||
(and col (output str) (+ col (string-length str))))
|
||||
|
||||
(define expr-found
|
||||
(lambda (ref col)
|
||||
(let ([n cycle-counter])
|
||||
(set! cycle-counter (add1 cycle-counter))
|
||||
(set-mark-str! ref
|
||||
(string-append "#"
|
||||
(number->string n)
|
||||
"#"))
|
||||
(set-mark-def! ref def-box)
|
||||
(out (string-append "#"
|
||||
(number->string n)
|
||||
"=")
|
||||
col))))
|
||||
|
||||
(define check-expr-found
|
||||
(lambda (obj check? col c-k d-k n-k)
|
||||
(let ([ref (and check?
|
||||
found
|
||||
(hash-table-get found obj (lambda () #f)))])
|
||||
(if (and ref (unbox (mark-def ref)))
|
||||
(if c-k
|
||||
(c-k (mark-str ref) col)
|
||||
(out (mark-str ref) col))
|
||||
(if (and ref d-k)
|
||||
(d-k col)
|
||||
(let ([col (if ref
|
||||
(expr-found ref col)
|
||||
col)])
|
||||
(n-k col)))))))
|
||||
|
||||
(define (wr obj col depth)
|
||||
|
||||
(define (wr-expr expr col depth)
|
||||
(if (read-macro? expr)
|
||||
(wr (read-macro-body expr) (out (read-macro-prefix expr) col) depth)
|
||||
(wr-lst expr col #t depth)))
|
||||
|
||||
(define (wr-lst l col check? depth)
|
||||
(if (pair? l)
|
||||
(check-expr-found
|
||||
l check? col
|
||||
#f #f
|
||||
(lambda (col)
|
||||
(if (and depth (zero? depth))
|
||||
(out "(...)" col)
|
||||
(let loop ((l (cdr l)) (col (wr (car l) (out "(" col) (dsub1 depth))))
|
||||
(check-expr-found
|
||||
l (and check? (pair? l)) col
|
||||
(lambda (s col) (out ")" (out s (out " . " col))))
|
||||
(lambda (col)
|
||||
(out ")" (wr-lst l (out " . " col) check? (dsub1 depth))))
|
||||
(lambda (col)
|
||||
(and col
|
||||
(cond
|
||||
((pair? l)
|
||||
(if (and (eq? (car l) 'unquote)
|
||||
(pair? (cdr l))
|
||||
(null? (cddr l)))
|
||||
(out ")" (wr (cadr l) (out " . ," col) (dsub1 depth)))
|
||||
(loop (cdr l) (wr (car l) (out " " col) (dsub1 depth)))))
|
||||
((null? l) (out ")" col))
|
||||
(else
|
||||
(out ")" (wr l (out " . " col) (dsub1 depth))))))))))))
|
||||
(out "()" col)))
|
||||
|
||||
(pre-print obj)
|
||||
(begin0
|
||||
(if (and depth (negative? depth))
|
||||
(out "..." col)
|
||||
|
||||
(cond ((size-hook obj display?)
|
||||
=> (lambda (len)
|
||||
(and col
|
||||
(output-hooked obj len)
|
||||
(+ len col))))
|
||||
|
||||
((pair? obj) (wr-expr obj col depth))
|
||||
((null? obj) (wr-lst obj col #f depth))
|
||||
((vector? obj) (check-expr-found
|
||||
obj #t col
|
||||
#f #f
|
||||
(lambda (col)
|
||||
(wr-lst (let ([l (vector->list obj)])
|
||||
(if print-vec-length?
|
||||
(drop-repeated l)
|
||||
l))
|
||||
(let ([col (out "#" col)])
|
||||
(if print-vec-length?
|
||||
(out (number->string (vector-length obj)) col)
|
||||
col))
|
||||
#f depth))))
|
||||
((box? obj) (check-expr-found
|
||||
obj #t col
|
||||
#f #f
|
||||
(lambda (col)
|
||||
(wr (unbox obj) (out "#&" col)
|
||||
(dsub1 depth)))))
|
||||
((struct? obj) (if (and print-struct?
|
||||
(not (and depth
|
||||
(zero? depth))))
|
||||
(check-expr-found
|
||||
obj #t col
|
||||
#f #f
|
||||
(lambda (col)
|
||||
(wr-lst (vector->list
|
||||
(struct->vector obj))
|
||||
(out "#" col) #f
|
||||
depth)))
|
||||
(out
|
||||
(let ([p (open-output-string)]
|
||||
[p-s (print-struct)])
|
||||
(when p-s
|
||||
(print-struct #f))
|
||||
((if display? display write) obj p)
|
||||
(when p-s
|
||||
(print-struct p-s))
|
||||
(get-output-string p))
|
||||
col)))
|
||||
|
||||
((boolean? obj) (out (if obj "#t" "#f") col))
|
||||
((number? obj)
|
||||
(when (and show-inexactness?
|
||||
(inexact? obj))
|
||||
(out "#i" col))
|
||||
(out ((if exact-as-decimal?
|
||||
number->decimal-string
|
||||
number->string)
|
||||
obj) col))
|
||||
;; Let symbol get printed by default case to get proper quoting
|
||||
;; ((symbol? obj) (out (symbol->string obj) col))
|
||||
((string? obj) (if display?
|
||||
(out obj col)
|
||||
(let loop ((i 0) (j 0) (col (out "\"" col)))
|
||||
(if (and col (< j (string-length obj)))
|
||||
(let ((c (string-ref obj j)))
|
||||
(if (or (char=? c #\\)
|
||||
(char=? c #\"))
|
||||
(loop j
|
||||
(+ j 1)
|
||||
(out "\\"
|
||||
(out (substring obj i j)
|
||||
col)))
|
||||
(loop i (+ j 1) col)))
|
||||
(out "\""
|
||||
(out (substring obj i j) col))))))
|
||||
((char? obj) (if display?
|
||||
(out (make-string 1 obj) col)
|
||||
(out (case obj
|
||||
((#\space) "space")
|
||||
((#\newline) "newline")
|
||||
((#\linefeed) "linefeed")
|
||||
((#\return) "return")
|
||||
((#\rubout) "rubout")
|
||||
((#\backspace)"backspace")
|
||||
((#\nul) "nul")
|
||||
((#\page) "page")
|
||||
((#\tab) "tab")
|
||||
((#\vtab) "vtab")
|
||||
((#\newline) "newline")
|
||||
(else (make-string 1 obj)))
|
||||
(out "#\\" col))))
|
||||
|
||||
(else (out (let ([p (open-output-string)])
|
||||
((if display? display write) obj p)
|
||||
(get-output-string p))
|
||||
col))))
|
||||
(post-print obj)))
|
||||
|
||||
(define (pp obj col depth)
|
||||
|
||||
(define (spaces n col)
|
||||
(if (> n 0)
|
||||
(if (> n 7)
|
||||
(spaces (- n 8) (out " " col))
|
||||
(out (substring " " 0 n) col))
|
||||
col))
|
||||
|
||||
(define (indent to col)
|
||||
(and col
|
||||
(if (< to col)
|
||||
(and col
|
||||
(begin
|
||||
(set! line-number (add1 line-number))
|
||||
(let ([col (print-line line-number col)])
|
||||
(spaces (- to col) col))))
|
||||
(spaces (- to col) col))))
|
||||
|
||||
(define (pr obj col extra pp-pair depth)
|
||||
; may have to split on multiple lines
|
||||
(let* ([can-multi (or (pair? obj) (vector? obj)
|
||||
(box? obj) (and (struct? obj) print-struct?))]
|
||||
[ref (if can-multi
|
||||
(and found (hash-table-get found obj (lambda () #f)))
|
||||
#f)])
|
||||
(if (and can-multi
|
||||
(or (not ref) (not (unbox (mark-def ref)))))
|
||||
(let* ((result '())
|
||||
(result-tail #f)
|
||||
(new-def-box (box #t))
|
||||
(left (+ (- (- width col) extra) 1))
|
||||
(snoc (lambda (s len)
|
||||
(let ([v (cons s null)])
|
||||
(if result-tail
|
||||
(set-cdr! result-tail v)
|
||||
(set! result v))
|
||||
(set! result-tail v))
|
||||
(set! left (- left len))
|
||||
(> left 0))))
|
||||
(generic-write obj display? #f
|
||||
(lambda (s)
|
||||
(snoc s (string-length s)))
|
||||
(lambda (s l)
|
||||
(snoc (cons s l) l))
|
||||
depth
|
||||
new-def-box
|
||||
0
|
||||
(lambda (obj)
|
||||
(snoc (cons 'pre obj) 0))
|
||||
(lambda (obj)
|
||||
(snoc (cons 'post obj) 0)))
|
||||
(if (> left 0) ; all can be printed on one line
|
||||
(let loop ([result result][col col])
|
||||
(if (null? result)
|
||||
col
|
||||
(loop (cdr result)
|
||||
(+ (let ([v (car result)])
|
||||
(if (pair? v)
|
||||
(cond
|
||||
[(eq? (car v) 'pre)
|
||||
(pre-print (cdr v))
|
||||
col]
|
||||
[(eq? (car v) 'post)
|
||||
(post-print (cdr v))
|
||||
col]
|
||||
[else
|
||||
(output-hooked (car v) (cdr v))
|
||||
(+ col (cdr v))])
|
||||
(out (car result) col)))))))
|
||||
(begin
|
||||
(set-box! new-def-box #f)
|
||||
(let ([col
|
||||
(if ref
|
||||
(expr-found ref col)
|
||||
col)])
|
||||
(pre-print obj)
|
||||
(begin0
|
||||
(cond
|
||||
[(pair? obj) (pp-pair obj col extra depth)]
|
||||
[(vector? obj)
|
||||
(pp-list (let ([l (vector->list obj)])
|
||||
(if print-vec-length?
|
||||
(drop-repeated l)
|
||||
l))
|
||||
(let ([col (out "#" col)])
|
||||
(if print-vec-length?
|
||||
(out (number->string (vector-length obj)) col)
|
||||
col))
|
||||
extra pp-expr #f depth)]
|
||||
[(struct? obj)
|
||||
(pp-list (vector->list (struct->vector obj))
|
||||
(out "#" col) extra pp-expr #f depth)]
|
||||
[(box? obj)
|
||||
(pr (unbox obj) (out "#&" col) extra pp-pair depth)])
|
||||
(post-print obj))))))
|
||||
(wr obj col depth))))
|
||||
|
||||
(define (pp-expr expr col extra depth)
|
||||
(if (read-macro? expr)
|
||||
(pr (read-macro-body expr)
|
||||
(out (read-macro-prefix expr) col)
|
||||
extra
|
||||
pp-expr
|
||||
depth)
|
||||
(let ((head (car expr)))
|
||||
(if (symbol? head)
|
||||
(let ((proc (style head)))
|
||||
(if proc
|
||||
(proc expr col extra depth)
|
||||
(if (> (string-length (symbol->string head))
|
||||
max-call-head-width)
|
||||
(pp-general expr col extra #f #f #f pp-expr depth)
|
||||
(pp-list expr col extra pp-expr #t depth))))
|
||||
(pp-list expr col extra pp-expr #t depth)))))
|
||||
|
||||
; (head item1
|
||||
; item2
|
||||
; item3)
|
||||
(define (pp-call expr col extra pp-item depth)
|
||||
(let ((col* (wr (car expr) (out "(" col) (dsub1 depth))))
|
||||
(and col
|
||||
(pp-down (cdr expr) col* (+ col* 1) extra pp-item #t #t depth))))
|
||||
|
||||
; (head item1 item2
|
||||
; item3
|
||||
; item4)
|
||||
(define (pp-two-up expr col extra pp-item depth)
|
||||
(let ((col* (wr (car expr) (out "(" col) (dsub1 depth)))
|
||||
(col*2 (wr (cadr expr) (out " " col) (dsub1 depth))))
|
||||
(and col
|
||||
(pp-down (cddr expr) (+ col 1) (+ col 2) extra pp-item #t #t depth))))
|
||||
|
||||
; (head item1
|
||||
; item2
|
||||
; item3)
|
||||
(define (pp-one-up expr col extra pp-item depth)
|
||||
(let ((col* (wr (car expr) (out "(" col) (dsub1 depth))))
|
||||
(and col
|
||||
(pp-down (cdr expr) (+ col 1) (+ col 2) extra pp-item #t #t depth))))
|
||||
|
||||
; (item1
|
||||
; item2
|
||||
; item3)
|
||||
(define (pp-list l col extra pp-item check? depth)
|
||||
(let ((col (out "(" col)))
|
||||
(pp-down l col col extra pp-item #f check? depth)))
|
||||
|
||||
(define (pp-down l col1 col2 extra pp-item check-first? check-rest? depth)
|
||||
(let loop ((l l) (col col1) (check? check-first?))
|
||||
(and col
|
||||
(check-expr-found
|
||||
l (and check? (pair? l)) col
|
||||
(lambda (s col)
|
||||
(out ")" (out s (indent col2 (out "." (indent col2 col))))))
|
||||
(lambda (col)
|
||||
(out ")" (pr l (indent col2 (out "." (indent col2 col)))
|
||||
extra pp-item depth)))
|
||||
(lambda (col)
|
||||
(cond ((pair? l)
|
||||
(let ((rest (cdr l)))
|
||||
(let ((extra (if (null? rest) (+ extra 1) 0)))
|
||||
(loop rest
|
||||
(pr (car l) (indent col2 col)
|
||||
extra pp-item
|
||||
(dsub1 depth))
|
||||
check-rest?))))
|
||||
((null? l)
|
||||
(out ")" col))
|
||||
(else
|
||||
(out ")"
|
||||
(pr l
|
||||
(indent col2 (out "." (indent col2 col)))
|
||||
(+ extra 1)
|
||||
pp-item
|
||||
(dsub1 depth))))))))))
|
||||
|
||||
(define (pp-general expr col extra named? pp-1 pp-2 pp-3 depth)
|
||||
|
||||
(define (tail1 rest col1 col2 col3)
|
||||
(if (and pp-1 (pair? rest))
|
||||
(let* ((val1 (car rest))
|
||||
(rest (cdr rest))
|
||||
(extra (if (null? rest) (+ extra 1) 0)))
|
||||
(tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1 depth) col3))
|
||||
(tail2 rest col1 col2 col3)))
|
||||
|
||||
(define (tail2 rest col1 col2 col3)
|
||||
(if (and pp-2 (pair? rest))
|
||||
(let* ((val1 (car rest))
|
||||
(rest (cdr rest))
|
||||
(extra (if (null? rest) (+ extra 1) 0)))
|
||||
(tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2 depth)))
|
||||
(tail3 rest col1 col2)))
|
||||
|
||||
(define (tail3 rest col1 col2)
|
||||
(pp-down rest col2 col1 extra pp-3 #f #t depth))
|
||||
|
||||
(let* ((head (car expr))
|
||||
(rest (cdr expr))
|
||||
(col* (wr head (out "(" col) (dsub1 depth))))
|
||||
(if (and named? (pair? rest))
|
||||
(let* ((name (car rest))
|
||||
(rest (cdr rest))
|
||||
(col** (wr name (out " " col*) (dsub1 depth))))
|
||||
(tail1 rest (+ col indent-general) col** (+ col** 1)))
|
||||
(tail1 rest (+ col indent-general) col* (+ col* 1)))))
|
||||
|
||||
(define (pp-expr-list l col extra depth)
|
||||
(pp-list l col extra pp-expr #t depth))
|
||||
|
||||
(define (pp-lambda expr col extra depth)
|
||||
(pp-general expr col extra #f pp-expr-list #f pp-expr depth))
|
||||
|
||||
(define (pp-if expr col extra depth)
|
||||
(pp-general expr col extra #f pp-expr #f pp-expr depth))
|
||||
|
||||
(define (pp-cond expr col extra depth)
|
||||
(pp-list expr col extra pp-expr-list #t depth))
|
||||
|
||||
(define (pp-class expr col extra depth)
|
||||
(pp-two-up expr col extra pp-expr-list depth))
|
||||
|
||||
(define (pp-make-object expr col extra depth)
|
||||
(pp-one-up expr col extra pp-expr-list depth))
|
||||
|
||||
(define (pp-case expr col extra depth)
|
||||
(pp-general expr col extra #f pp-expr #f pp-expr-list depth))
|
||||
|
||||
(define (pp-and expr col extra depth)
|
||||
(pp-call expr col extra pp-expr depth))
|
||||
|
||||
(define (pp-let expr col extra depth)
|
||||
(let* ((rest (cdr expr))
|
||||
(named? (and (pair? rest) (symbol? (car rest)))))
|
||||
(pp-general expr col extra named? pp-expr-list #f pp-expr depth)))
|
||||
|
||||
(define (pp-begin expr col extra depth)
|
||||
(pp-general expr col extra #f #f #f pp-expr depth))
|
||||
|
||||
(define (pp-do expr col extra depth)
|
||||
(pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr depth))
|
||||
|
||||
; define formatting style (change these to suit your style)
|
||||
|
||||
(define indent-general 2)
|
||||
|
||||
(define max-call-head-width 5)
|
||||
|
||||
(define (style head)
|
||||
(case head
|
||||
((lambda let* letrec define shared
|
||||
unless #%unless
|
||||
when #%when
|
||||
'|$\spadesuit$|
|
||||
#%lambda #%let* #%letrec #%define
|
||||
define-macro #%define-macro)
|
||||
pp-lambda)
|
||||
((if set! #%if #%set!)
|
||||
pp-if)
|
||||
((cond #%cond public private import export)
|
||||
pp-cond)
|
||||
((case #%case)
|
||||
pp-case)
|
||||
((and or #%and #%or link)
|
||||
pp-and)
|
||||
((let #%let)
|
||||
pp-let)
|
||||
((begin #%begin)
|
||||
pp-begin)
|
||||
((do #%do)
|
||||
pp-do)
|
||||
|
||||
((send class #%class) pp-class)
|
||||
((send make-object) pp-make-object)
|
||||
|
||||
(else #f)))
|
||||
|
||||
(pr obj col 0 pp-expr depth))
|
||||
|
||||
(if (and width (not (eq? width 'infinity)))
|
||||
(pp obj startpos depth)
|
||||
(wr obj startpos depth)))))
|
||||
|
||||
(define pretty-print-handler
|
||||
(lambda (v)
|
||||
(unless (void? v)
|
||||
(pretty-print v))))
|
||||
|
||||
(define (number->decimal-string x)
|
||||
(cond
|
||||
[(or (inexact? x)
|
||||
(integer? x))
|
||||
(number->string x)]
|
||||
[(not (real? x))
|
||||
(let ([r (real-part x)]
|
||||
[i (imag-part x)])
|
||||
(format "~a~a~ai"
|
||||
(number->decimal-string r)
|
||||
(if (negative? i)
|
||||
""
|
||||
"+")
|
||||
(number->decimal-string i)))]
|
||||
[else
|
||||
(let ([n (numerator x)]
|
||||
[d (denominator x)])
|
||||
;; Count powers of 2 in denomintor
|
||||
(let loop ([v d][2-power 0])
|
||||
(if (and (positive? v)
|
||||
(even? v))
|
||||
(loop (arithmetic-shift v -1) (add1 2-power))
|
||||
;; Count powers of 5 in denominator
|
||||
(let loop ([v v][5-power 0])
|
||||
(if (zero? (remainder v 5))
|
||||
(loop (quotient v 5) (add1 5-power))
|
||||
;; No more 2s or 5s. Anything left?
|
||||
(if (= v 1)
|
||||
;; Denominator = (* (expt 2 2-power) (expt 5 5-power)).
|
||||
;; Print number as decimal.
|
||||
(let* ([10-power (max 2-power 5-power)]
|
||||
[scale (* (expt 2 (- 10-power 2-power))
|
||||
(expt 5 (- 10-power 5-power)))]
|
||||
[s (number->string (* (abs n) scale))]
|
||||
[orig-len (string-length s)]
|
||||
[len (max (add1 10-power) orig-len)]
|
||||
[padded-s (if (< orig-len len)
|
||||
(string-append
|
||||
(make-string (- len orig-len) #\0)
|
||||
s)
|
||||
s)])
|
||||
(format "~a~a.~a"
|
||||
(if (negative? n) "-" "")
|
||||
(substring padded-s 0 (- len 10-power))
|
||||
(substring padded-s (- len 10-power) len)))
|
||||
;; d has factor(s) other than 2 and 5.
|
||||
;; Print as a fraction.
|
||||
(number->string x)))))))]))
|
||||
|
||||
)
|
||||
16
collects/mzlib/prettys.ss
Normal file
16
collects/mzlib/prettys.ss
Normal file
|
|
@ -0,0 +1,16 @@
|
|||
|
||||
(define-signature mzlib:pretty-print^
|
||||
(pretty-print
|
||||
pretty-display
|
||||
pretty-print-columns
|
||||
pretty-print-depth
|
||||
pretty-print-handler
|
||||
pretty-print-size-hook
|
||||
pretty-print-print-hook
|
||||
pretty-print-pre-print-hook
|
||||
pretty-print-post-print-hook
|
||||
pretty-print-display-string-handler
|
||||
pretty-print-print-line
|
||||
pretty-print-show-inexactness
|
||||
pretty-print-exact-as-decimal))
|
||||
|
||||
8
collects/mzlib/prettyu.ss
Normal file
8
collects/mzlib/prettyu.ss
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
|
||||
(require-library "prettys.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "refer.ss"))
|
||||
|
||||
(define mzlib:pretty-print@ (require-library-unit/sig "prettyr.ss"))
|
||||
|
||||
22
collects/mzlib/refer.ss
Normal file
22
collects/mzlib/refer.ss
Normal file
|
|
@ -0,0 +1,22 @@
|
|||
|
||||
(define-macro begin-construction-time
|
||||
(lambda body
|
||||
`(#%begin-elaboration-time ,@body)))
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(begin-elaboration-time
|
||||
(define-values/invoke-unit (require-unit reference-file)
|
||||
(require-library "referf.ss")))
|
||||
|
||||
(define-macro require-library-unit/sig (require-unit #t #t #f #t 'require-library-unit/sig))
|
||||
(define-macro require-library-unit (require-unit #t #t #f #f 'require-library-unit))
|
||||
(define-macro require-relative-library-unit/sig (require-unit #t #t #t #t 'require-relative-library-unit/sig))
|
||||
(define-macro require-relative-library-unit (require-unit #t #t #t #f 'require-relative-library-unit))
|
||||
(define-macro require-unit/sig (require-unit #t #f #f #t 'require-unit/sig))
|
||||
(define-macro require-unit (require-unit #t #f #f #f 'require-unit))
|
||||
|
||||
(define-macro reference-file (reference-file #t #f #f))
|
||||
|
||||
(require-library "spidey.ss")
|
||||
76
collects/mzlib/referf.ss
Normal file
76
collects/mzlib/referf.ss
Normal file
|
|
@ -0,0 +1,76 @@
|
|||
|
||||
(unit
|
||||
(import)
|
||||
(export (make-require-unit require-unit) (make-require reference-file))
|
||||
|
||||
(define make-require-unit
|
||||
; require-unit, etc.
|
||||
(lambda (must-string? require? reqrel? sig? sname)
|
||||
(lambda names
|
||||
(let ([len (length names)]
|
||||
[expect (if require? +inf.0 1)])
|
||||
(unless (and (positive? len) (<= len expect))
|
||||
((raise-syntax-error sname
|
||||
(format "expected ~a names; given ~a"
|
||||
(if (= +inf.0 expect)
|
||||
"some"
|
||||
expect)
|
||||
len)
|
||||
(list* sname names)))))
|
||||
(let ([names (if must-string?
|
||||
(map local-expand-defmacro names)
|
||||
names)])
|
||||
(unless (or (not must-string?))
|
||||
(for-each
|
||||
(lambda (s)
|
||||
(unless s
|
||||
(raise-syntax-error sname
|
||||
"name is not a string"
|
||||
(list* sname names)
|
||||
s)))
|
||||
names))
|
||||
`(#%let ([result (,(if require?
|
||||
(if reqrel?
|
||||
'#%require-relative-library/proc
|
||||
'#%require-library/proc)
|
||||
'#%load/use-compiled) ,@names)])
|
||||
(#%unless (,(if sig?
|
||||
'#%unit/sig?
|
||||
'#%unit?)
|
||||
result)
|
||||
(#%raise
|
||||
(#%make-exn:unit
|
||||
,(format "~s: result from ~s is not a ~aunit"
|
||||
sname names (if sig? "signed " ""))
|
||||
(#%current-continuation-marks))))
|
||||
result)))))
|
||||
|
||||
(define make-require
|
||||
; require
|
||||
(lambda (must-string? require? reqrel?)
|
||||
(lambda names
|
||||
(let ([sname (if require?
|
||||
(if reqrel?
|
||||
'require-relative-library
|
||||
'require-library)
|
||||
'require)]
|
||||
[len (length names)]
|
||||
[expect (if require? +inf.0 1)])
|
||||
(unless (and (positive? len) (<= len expect))
|
||||
((raise-syntax-error sname
|
||||
(format "expected ~a names; given ~a"
|
||||
expect len)
|
||||
(list* sname names))))
|
||||
(let ([names (if must-string?
|
||||
(map local-expand-defmacro names)
|
||||
names)])
|
||||
(unless (or (not must-string?) (map string? names))
|
||||
(raise-syntax-error sname
|
||||
"filename is not a string"
|
||||
(list* sname names)))
|
||||
`(,(if require?
|
||||
(if reqrel?
|
||||
'require-relative-library/proc
|
||||
'require-library/proc)
|
||||
'#%load/use-compiled)
|
||||
,@names)))))))
|
||||
11
collects/mzlib/restart.ss
Normal file
11
collects/mzlib/restart.ss
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
|
||||
(require-library "cmdline.ss")
|
||||
(require-library "restartu.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:restart^
|
||||
mzlib:restart@
|
||||
#f
|
||||
mzlib:command-line^)
|
||||
178
collects/mzlib/restartr.ss
Normal file
178
collects/mzlib/restartr.ss
Normal file
|
|
@ -0,0 +1,178 @@
|
|||
|
||||
(unit/sig mzlib:restart^
|
||||
(import mzlib:command-line^)
|
||||
|
||||
(define (restart-mzscheme init-argv adjust-flag-table argv init-namespace)
|
||||
(let* ([args #f]
|
||||
[mute-banner? #f]
|
||||
[no-rep? #f]
|
||||
[no-coll-paths? #f]
|
||||
[no-init-file? #f]
|
||||
[case-sensitive? #f]
|
||||
[esc-cont-only? #f]
|
||||
[allow-set!-undefined? #t]
|
||||
[no-auto-else? #f]
|
||||
[no-enforce-keywords? #f]
|
||||
[hp-only? #f]
|
||||
[print-error
|
||||
(lambda (e)
|
||||
(if (exn? e)
|
||||
(fprintf (current-error-port) "~a~n" (exn-message e))
|
||||
(fprintf (current-error-port) "Exception in init file: ~e~n" e)))]
|
||||
[table
|
||||
`([multi
|
||||
[("-e")
|
||||
,(lambda (f expr) expr)
|
||||
("Evaluates <expr>" "expr")]
|
||||
[("-f")
|
||||
,(lambda (f file) (format "(load ~s)" file))
|
||||
("Loads <file>" "file")]
|
||||
[("-f")
|
||||
,(lambda (f file) (format "(load/cd ~s)" file))
|
||||
("Load/cds <file>" "file")]
|
||||
[("-F")
|
||||
,(lambda (f . files) (map (lambda (file)
|
||||
(format "(load ~s)" file))
|
||||
files))
|
||||
("Loads all <file>s" "file")]
|
||||
[("-D")
|
||||
,(lambda (f . files) (map (lambda (file)
|
||||
(format "(load/cd ~s)" file))
|
||||
files))
|
||||
("Load/cds all <file>s" "file")]
|
||||
[("-l")
|
||||
,(lambda (f file) (format "(require-library ~s)" file))
|
||||
("Requires library <file>" "file")]
|
||||
[("-L")
|
||||
,(lambda (f file collection) (format "(require-library ~s ~s)" file collection))
|
||||
("Requires library <file> in <collection>" "file" "collection")]
|
||||
[("-r" "--script")
|
||||
,(lambda (f file . rest)
|
||||
(format "(load ~s)" file)
|
||||
(set! mute-banner? #t)
|
||||
(set! no-rep? #t)
|
||||
(set! args rest))
|
||||
("Same as -fmv-" "file" "arg")]
|
||||
[("-i" "--script-cd")
|
||||
,(lambda (f file . rest)
|
||||
(format "(load/cd ~s)" file)
|
||||
(set! mute-banner? #t)
|
||||
(set! no-rep? #t)
|
||||
(set! args rest))
|
||||
("Same as -dmv-" "file" "arg")]
|
||||
[("-w" "--awk")
|
||||
,(lambda (f) "(require-library \"awk.ss\")")
|
||||
("Same as -l awk.ss")]
|
||||
[("-x" "--no-init-path")
|
||||
,(lambda (f) (set! no-coll-paths? #t))
|
||||
("Don't set current-library-collection-paths")]
|
||||
[("-q" "--no-init-file")
|
||||
,(lambda (f) (set! no-init-file? #t))
|
||||
("Don't load \"~/.mzschemerc\" or \"mzscheme.rc\"")]
|
||||
[("-g" "--case-sens")
|
||||
,(lambda (f) (set! case-sensitive? #t))
|
||||
("Identifiers and symbols are initially case-sensitive")]
|
||||
[("-c" "--esc-cont")
|
||||
,(lambda (f) (set! esc-cont-only? #t))
|
||||
("Call/cc is replaced with call/ec")]
|
||||
[("-s" "--set-undef")
|
||||
,(lambda (f) (set! allow-set!-undefined? #t))
|
||||
("Set! works on undefined identifiers")]
|
||||
[("-a" "--no-auto-else")
|
||||
,(lambda (f) (set! no-auto-else? #t))
|
||||
("Fall-through cond or case is an error")]
|
||||
[("-n" "--no-key")
|
||||
,(lambda (f) (set! no-enforce-keywords? #t))
|
||||
("Keywords are not enforced")]
|
||||
[("-y" "--hash-percent-syntax")
|
||||
,(lambda (f) (set! hp-only? #t))
|
||||
("Only #% syntactic forms are present")]
|
||||
[("-m" "--mute-banner")
|
||||
,(lambda (f) (set! mute-banner? #t))
|
||||
("Suppresses the startup banner text")]
|
||||
[("-v" "--version")
|
||||
,(lambda (f) (set! no-rep? #t))
|
||||
("Suppresses the read-eval-print loop")]
|
||||
[("--restore")
|
||||
,(lambda (f) (error 'mzscheme "The --restore flag is not supported in this mode"))
|
||||
("Not supported")]])])
|
||||
(parse-command-line
|
||||
"mzscheme"
|
||||
argv
|
||||
table
|
||||
void
|
||||
'("ignored"))
|
||||
(set! args #f)
|
||||
(parse-command-line
|
||||
"mzscheme"
|
||||
argv
|
||||
(adjust-flag-table table)
|
||||
(lambda (exprs . rest)
|
||||
(unless (null? rest)
|
||||
(set! args rest))
|
||||
;(when args (set! rest args))
|
||||
(let ([n (make-namespace
|
||||
(if no-enforce-keywords? 'no-keywords 'keywords)
|
||||
(if esc-cont-only? 'call/cc=call/ec 'call/cc!=call/ec)
|
||||
(if hp-only? 'hash-percent-syntax 'all-syntax))])
|
||||
(thread-wait
|
||||
(thread
|
||||
(lambda ()
|
||||
(current-namespace n)
|
||||
(let ([program (with-handlers ([void (lambda (x) "MzScheme")])
|
||||
(global-defined-value 'program))])
|
||||
(read-case-sensitive case-sensitive?)
|
||||
(compile-allow-set!-undefined allow-set!-undefined?)
|
||||
(compile-allow-cond-fallthrough (not no-auto-else?))
|
||||
|
||||
(unless mute-banner? (display (banner)))
|
||||
|
||||
(eval `(#%define-values (argv) (#%quote ,(if args (list->vector args) (vector)))))
|
||||
(eval `(#%define-values (program) (#%quote ,program)))
|
||||
|
||||
(current-library-collection-paths
|
||||
(if no-coll-paths?
|
||||
#f
|
||||
(path-list-string->path-list
|
||||
(or (getenv "PLTCOLLECTS") "")
|
||||
(or
|
||||
(ormap
|
||||
(lambda (f) (let ([p (f)]) (and p (directory-exists? p) (list p))))
|
||||
(list
|
||||
(lambda () (let ((v (getenv "PLTHOME")))
|
||||
(and v (build-path v "collects"))))
|
||||
(lambda () (find-executable-path program "collects"))
|
||||
(lambda ()
|
||||
(case (system-type)
|
||||
[(unix beos) "/usr/local/lib/plt/collects"]
|
||||
[(windows) "c:\\plt\\collects"]
|
||||
[else #f]))))
|
||||
null)))))
|
||||
|
||||
(init-namespace)
|
||||
|
||||
(unless no-init-file?
|
||||
(let ([f (case (system-type)
|
||||
[(unix beos) "~/.mzschemerc"]
|
||||
[else "mzscheme.rc"])])
|
||||
(when (file-exists? f)
|
||||
(with-handlers ([void print-error])
|
||||
(load f)))))
|
||||
|
||||
(let ([result
|
||||
(let/ec escape
|
||||
(for-each
|
||||
(lambda (e)
|
||||
(with-handlers ([void (lambda (e) (print-error e) (escape #f))])
|
||||
(eval (read (open-input-string e)))))
|
||||
exprs)
|
||||
#t)])
|
||||
(let/ec k
|
||||
(exit-handler
|
||||
(lambda (status)
|
||||
(when result
|
||||
(set! result (= status 0)))
|
||||
(k #f)))
|
||||
(unless no-rep? (read-eval-print-loop)))
|
||||
result))))))
|
||||
`("arg")))))
|
||||
6
collects/mzlib/restarts.ss
Normal file
6
collects/mzlib/restarts.ss
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
|
||||
(begin-elaboration-time
|
||||
(require-library "cmdlines.ss"))
|
||||
|
||||
(define-signature mzlib:restart^
|
||||
(restart-mzscheme))
|
||||
7
collects/mzlib/restartu.ss
Normal file
7
collects/mzlib/restartu.ss
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
|
||||
(require-library "restarts.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "refer.ss"))
|
||||
|
||||
(define mzlib:restart@ (require-library-unit/sig "restartr.ss"))
|
||||
14
collects/mzlib/shared.ss
Normal file
14
collects/mzlib/shared.ss
Normal file
|
|
@ -0,0 +1,14 @@
|
|||
|
||||
(begin-elaboration-time
|
||||
(require-library "functios.ss"))
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(begin-elaboration-time
|
||||
(define-values/invoke-unit (shared)
|
||||
(require-library "sharedr.ss")))
|
||||
|
||||
(define-macro shared shared)
|
||||
|
||||
|
||||
146
collects/mzlib/sharedr.ss
Normal file
146
collects/mzlib/sharedr.ss
Normal file
|
|
@ -0,0 +1,146 @@
|
|||
|
||||
(unit/sig->unit
|
||||
(compound-unit/sig
|
||||
(import)
|
||||
(link [FUNCTION : mzlib:function^ ((require-library "functior.ss") )]
|
||||
[SHARED : (shared) (
|
||||
|
||||
(unit/sig (shared)
|
||||
(import mzlib:function^)
|
||||
|
||||
;; SHARED starts here
|
||||
|
||||
(define shared
|
||||
(let ()
|
||||
(define-struct twople (left right))
|
||||
(define-struct cons-rhs (id car cdr))
|
||||
(define-struct vector-rhs (id args))
|
||||
(define-struct box-rhs (id arg))
|
||||
(define-struct weak-box-rhs (id let arg))
|
||||
(define-struct trans (rhs lets set!s))
|
||||
(lambda (defns . body)
|
||||
(letrec ([bad (lambda (s sexp)
|
||||
(error 'shared (string-append s ": ~a") sexp))]
|
||||
[build-args
|
||||
(lambda (args howmany)
|
||||
(cond
|
||||
[(null? args) '()]
|
||||
[(pair? args) (cons (car args)
|
||||
(build-args (cdr args)
|
||||
(if (number? howmany)
|
||||
(sub1 howmany)
|
||||
howmany)))]
|
||||
[else (bad "args" args)]))]
|
||||
[build-args1
|
||||
(lambda (x)
|
||||
(cond
|
||||
[(and (pair? x) (null? (cdr x))) (list (car x))]
|
||||
[else (bad "args" x)]))]
|
||||
[build-args2
|
||||
(lambda (x)
|
||||
(if (pair? x)
|
||||
(let ((xcdr (cdr x)))
|
||||
(if (pair? xcdr)
|
||||
(let ((xcdrcdr (cdr xcdr)))
|
||||
(if (null? xcdrcdr)
|
||||
(list (car x) (car xcdr))
|
||||
(bad "args" x)))
|
||||
(bad "args" x)))
|
||||
(bad "args" x)))]
|
||||
[build-defn
|
||||
(lambda (x)
|
||||
(unless (and (pair? x)
|
||||
(symbol? (car x)))
|
||||
(bad "bad binding" x))
|
||||
(if (not (and (pair? (cdr x))
|
||||
(pair? (cadr x))
|
||||
(symbol? (caadr x))))
|
||||
(make-trans x '() '())
|
||||
(let ([id (car x)]
|
||||
[constructor (caadr x)]
|
||||
[args (cdadr x)])
|
||||
(case constructor
|
||||
[(list) (let ([args (build-args args 'whatever)])
|
||||
(if (null? args)
|
||||
(make-trans `(,id (list))
|
||||
'()
|
||||
'())
|
||||
(make-cons-rhs id (car args) `(list ,@(cdr args)))))]
|
||||
[(vector) (let ([args (build-args args 'whatever)])
|
||||
(make-vector-rhs id args))]
|
||||
[(box) (let ([args (build-args1 args)])
|
||||
(make-box-rhs id (car args)))]
|
||||
; [(make-weak-box) (let ([args (build-args1 args)])
|
||||
; (make-weak-box-rhs id (car args)))]
|
||||
[(cons) (let ([args (build-args2 args)])
|
||||
(make-cons-rhs id (car args) (cadr args)))]
|
||||
[else (make-trans x '() '())]))))]
|
||||
[build-defns
|
||||
(lambda (x)
|
||||
(cond
|
||||
[(null? x) '()]
|
||||
[(pair? x) (cons (build-defn (car x))
|
||||
(build-defns (cdr x)))]
|
||||
[else (bad "defns list" x)]))]
|
||||
[transform
|
||||
(lambda (binding)
|
||||
(cond
|
||||
[(vector-rhs? binding)
|
||||
(let ()
|
||||
(define-struct b&s (bind set!))
|
||||
(let* ([id (vector-rhs-id binding)])
|
||||
(let ([elems
|
||||
(twople-left
|
||||
(foldl (lambda (x data)
|
||||
(let ([list (twople-left data)]
|
||||
[i (twople-right data)]
|
||||
[eid (gensym)])
|
||||
(make-twople (cons (make-b&s `(,eid ,x)
|
||||
`(vector-set! ,id ,i ,eid))
|
||||
list)
|
||||
(+ i 1))))
|
||||
(make-twople '() 0)
|
||||
(vector-rhs-args binding)))])
|
||||
(make-trans `(,id (vector ,@(map (lambda (x) '(void))
|
||||
(vector-rhs-args binding))))
|
||||
(map b&s-bind elems)
|
||||
(map b&s-set! elems)))))]
|
||||
[(box-rhs? binding)
|
||||
(let ([id (box-rhs-id binding)]
|
||||
[eid (gensym)])
|
||||
(make-trans `(,id (box (void)))
|
||||
(list `(,eid ,(box-rhs-arg binding)))
|
||||
(list `(set-box! ,id ,eid))))]
|
||||
[(weak-box-rhs? binding)
|
||||
(let ([id (weak-box-rhs-id binding)]
|
||||
[eid (gensym)])
|
||||
(make-trans `(,id (make-weak-box (void)))
|
||||
(list `(,eid ,(weak-box-rhs-arg binding)))
|
||||
(list `(set-weak-box! ,id ,eid))))]
|
||||
[(cons-rhs? binding)
|
||||
(let ([id (cons-rhs-id binding)]
|
||||
[car-id (gensym)]
|
||||
[cdr-id (gensym)])
|
||||
(make-trans `(,id (cons (void) (void)))
|
||||
(list `(,car-id ,(cons-rhs-car binding))
|
||||
`(,cdr-id ,(cons-rhs-cdr binding)))
|
||||
(list `(set-car! ,id ,car-id)
|
||||
`(set-cdr! ,id ,cdr-id))))]
|
||||
[(trans? binding) binding]
|
||||
[else (bad "internal error:" binding)]))]
|
||||
[transformed-defns (map transform (build-defns defns))])
|
||||
(list 'letrec
|
||||
(map trans-rhs transformed-defns)
|
||||
(list 'let (apply append (map trans-lets transformed-defns))
|
||||
(cons 'begin
|
||||
(append (apply append (map trans-set!s transformed-defns))
|
||||
body)))))))))
|
||||
|
||||
|
||||
;; SHARED ends here
|
||||
|
||||
FUNCTION)])
|
||||
|
||||
(export (var (SHARED shared)))))
|
||||
|
||||
|
||||
15
collects/mzlib/spidey.ss
Normal file
15
collects/mzlib/spidey.ss
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
|
||||
(define-macro define-constructor
|
||||
(lambda args '(#%void)))
|
||||
|
||||
(define-macro define-type
|
||||
(lambda args '(#%void)))
|
||||
|
||||
(define-macro :
|
||||
(lambda (v . args) v))
|
||||
|
||||
(define-macro mrspidey:control
|
||||
(lambda args '(#%void)))
|
||||
|
||||
(define-macro polymorphic
|
||||
(lambda (arg) arg))
|
||||
9
collects/mzlib/string.ss
Normal file
9
collects/mzlib/string.ss
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
|
||||
(require-library "stringu.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:string^
|
||||
mzlib:string@)
|
||||
|
||||
104
collects/mzlib/stringr.ss
Normal file
104
collects/mzlib/stringr.ss
Normal file
|
|
@ -0,0 +1,104 @@
|
|||
(unit/sig
|
||||
mzlib:string^
|
||||
(import)
|
||||
|
||||
(define make-string-do!
|
||||
(lambda (translate)
|
||||
(lambda (s)
|
||||
(let loop ([n (sub1 (string-length s))])
|
||||
(unless (negative? n)
|
||||
(string-set! s n
|
||||
(translate (string-ref s n)))
|
||||
(loop (sub1 n)))))))
|
||||
(define string-lowercase! (make-string-do! char-downcase))
|
||||
(define string-uppercase! (make-string-do! char-upcase))
|
||||
|
||||
(define eval-string
|
||||
(let ([do-eval
|
||||
(lambda (str)
|
||||
(let ([p (open-input-string str)])
|
||||
(apply
|
||||
values
|
||||
(let loop ()
|
||||
(let ([e (read p)])
|
||||
(if (eof-object? e)
|
||||
'()
|
||||
(call-with-values
|
||||
(lambda () (eval e))
|
||||
(case-lambda
|
||||
[() (loop)]
|
||||
[(only) (cons only (loop))]
|
||||
[multi
|
||||
(append multi (loop))]))))))))])
|
||||
(case-lambda
|
||||
[(str) (eval-string str #f #f)]
|
||||
[(str error-display) (eval-string str error-display #f)]
|
||||
[(str error-display error-result)
|
||||
(if (or error-display error-result)
|
||||
(with-handlers ([void
|
||||
(lambda (exn)
|
||||
((or error-display (error-display-handler))
|
||||
(exn-message exn))
|
||||
(if error-result
|
||||
(error-result)
|
||||
#f))])
|
||||
(do-eval str))
|
||||
(do-eval str))])))
|
||||
|
||||
(define read-from-string-one-or-all
|
||||
(case-lambda
|
||||
[(k all? str) (read-from-string-one-or-all k all? str #f #f)]
|
||||
[(k all? str error-display) (read-from-string-one-or-all k all? str error-display #f)]
|
||||
[(k all? str error-display error-result)
|
||||
(let* ([p (open-input-string str)]
|
||||
[go (lambda ()
|
||||
(let loop ()
|
||||
(let ([v (read p)])
|
||||
(if (eof-object? v)
|
||||
'()
|
||||
(cons v
|
||||
(if all?
|
||||
(loop)
|
||||
'()))))))])
|
||||
(if error-display
|
||||
(with-handlers ([void
|
||||
(lambda (exn)
|
||||
((or error-display (error-display-handler))
|
||||
(exn-message exn))
|
||||
(k (if error-result
|
||||
(error-result)
|
||||
#f)))])
|
||||
(go))
|
||||
(go)))]))
|
||||
|
||||
(define read-from-string
|
||||
(lambda args
|
||||
(let/ec k
|
||||
(let ([l (apply read-from-string-one-or-all k #f args)])
|
||||
(if (null? l)
|
||||
eof
|
||||
(car l))))))
|
||||
|
||||
(define read-from-string-all
|
||||
(lambda args
|
||||
(let/ec k
|
||||
(apply read-from-string-one-or-all k #t args))))
|
||||
|
||||
(define expr->string
|
||||
(lambda (v)
|
||||
(let* ([s ""]
|
||||
[write-to-s
|
||||
(lambda (str)
|
||||
(set! s (string-append s str)))]
|
||||
[port (make-output-port write-to-s (lambda () #f))])
|
||||
(write v port)
|
||||
s)))
|
||||
|
||||
(define newline-string (string #\newline))
|
||||
|
||||
(define regexp-match-exact?
|
||||
(lambda (p s)
|
||||
(let ([m (regexp-match p s)])
|
||||
(and m
|
||||
(string=? (car m) s)))))
|
||||
)
|
||||
11
collects/mzlib/strings.ss
Normal file
11
collects/mzlib/strings.ss
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
|
||||
(define-signature mzlib:string^
|
||||
(string-lowercase!
|
||||
string-uppercase!
|
||||
eval-string
|
||||
read-from-string
|
||||
read-from-string-all
|
||||
expr->string
|
||||
newline-string
|
||||
regexp-match-exact?))
|
||||
|
||||
7
collects/mzlib/stringu.ss
Normal file
7
collects/mzlib/stringu.ss
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
|
||||
(require-library "strings.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "refer.ss"))
|
||||
|
||||
(define mzlib:string@ (require-library-unit/sig "stringr.ss"))
|
||||
22
collects/mzlib/synrule.ss
Normal file
22
collects/mzlib/synrule.ss
Normal file
|
|
@ -0,0 +1,22 @@
|
|||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(begin-elaboration-time
|
||||
(define-values/invoke-unit (define-syntax
|
||||
-:sr:tag
|
||||
-:sr:untag
|
||||
-:sr:flatten
|
||||
-:sr:matches-pattern?
|
||||
-:sr:get-bindings
|
||||
-:sr:expand-pattern)
|
||||
(require-library "synruler.ss")))
|
||||
|
||||
(define-macro define-syntax define-syntax)
|
||||
|
||||
(keyword-name '-:sr:tag)
|
||||
(keyword-name '-:sr:untag)
|
||||
(keyword-name '-:sr:flatten)
|
||||
(keyword-name '-:sr:matches-pattern?)
|
||||
(keyword-name '-:sr:get-bindings)
|
||||
(keyword-name '-:sr:expand-pattern)
|
||||
429
collects/mzlib/synruler.ss
Normal file
429
collects/mzlib/synruler.ss
Normal file
|
|
@ -0,0 +1,429 @@
|
|||
; By Dorai Sitaram
|
||||
; then Shriram Krishnamurthi
|
||||
; then Matthew Flatt
|
||||
|
||||
(unit
|
||||
(import)
|
||||
(export define-syntax
|
||||
-:sr:tag
|
||||
-:sr:untag
|
||||
-:sr:flatten
|
||||
-:sr:matches-pattern?
|
||||
-:sr:get-bindings
|
||||
-:sr:expand-pattern)
|
||||
|
||||
(define -:sr:tag 'undefined--:sr:tag)
|
||||
(define -:sr:untag 'undefined--:sr:untag)
|
||||
(define -:sr:flatten 'undefined--:sr:flatten)
|
||||
|
||||
(letrec ([hyg:rassq
|
||||
(lambda (k al)
|
||||
(let loop ([al al])
|
||||
(if (null? al)
|
||||
#f
|
||||
(let ([c (car al)])
|
||||
(if (eq? (cdr c) k)
|
||||
c
|
||||
(loop (cdr al)))))))]
|
||||
[hyg:tag
|
||||
(lambda (e kk al)
|
||||
(cond
|
||||
[(pair? e)
|
||||
(let* ((a-te-al (hyg:tag (car e) kk al))
|
||||
(d-te-al (hyg:tag (cdr e) kk (cdr a-te-al))))
|
||||
(cons (cons (car a-te-al) (car d-te-al))
|
||||
(cdr d-te-al)))]
|
||||
[(vector? e)
|
||||
(let ([v-te-al (hyg:tag (vector->list e) kk al)])
|
||||
(cons (list->vector (car v-te-al))
|
||||
(cdr v-te-al)))]
|
||||
[(symbol? e)
|
||||
(cond
|
||||
[(eq? e '...) (cons '... al)]
|
||||
[(memq e kk) (cons e al)]
|
||||
[(hyg:rassq e al)
|
||||
=> (lambda (c)
|
||||
(cons (car c) al))]
|
||||
[else
|
||||
(let ((te (gensym)))
|
||||
(cons te (cons (cons te e) al)))])]
|
||||
[else (cons e al)]))]
|
||||
[hyg:untag
|
||||
(lambda (e al tmps)
|
||||
(if (pair? e)
|
||||
(let ([a (hyg:untag (car e) al tmps)])
|
||||
(if (list? e)
|
||||
(case a
|
||||
[(quote)
|
||||
(hyg:untag-no-tags e al)]
|
||||
[(quasiquote)
|
||||
(list a (hyg:untag-quasiquote (cadr e) al tmps))]
|
||||
[(if begin)
|
||||
`(,a ,@(map (lambda (e1)
|
||||
(hyg:untag e1 al tmps)) (cdr e)))]
|
||||
[(set! define)
|
||||
`(,a ,(hyg:untag-vanilla (cadr e) al tmps)
|
||||
,@(map (lambda (e1)
|
||||
(hyg:untag e1 al tmps)) (cddr e)))]
|
||||
[(lambda)
|
||||
(hyg:untag-lambda a (cadr e) (cddr e) al tmps)]
|
||||
[(letrec)
|
||||
(hyg:untag-letrec a (cadr e) (cddr e) al tmps)]
|
||||
[(let)
|
||||
(let ((e2 (cadr e)))
|
||||
(if (symbol? e2)
|
||||
(hyg:untag-named-let a e2 (caddr e) (cdddr e) al tmps)
|
||||
(hyg:untag-let a e2 (cddr e) al tmps)))]
|
||||
[(let*)
|
||||
(hyg:untag-let* (cadr e) (cddr e) al tmps)]
|
||||
[(do) (hyg:untag-do (cadr e) (caddr e) (cdddr e) al tmps)]
|
||||
[(case)
|
||||
`(case ,(hyg:untag-vanilla (cadr e) al tmps)
|
||||
,@(map
|
||||
(lambda (c)
|
||||
`(,(hyg:untag-vanilla (car c) al tmps)
|
||||
,@(hyg:untag-list (cdr c) al tmps)))
|
||||
(cddr e)))]
|
||||
[(cond)
|
||||
`(cond ,@(map
|
||||
(lambda (c)
|
||||
(hyg:untag-list c al tmps))
|
||||
(cdr e)))]
|
||||
[else
|
||||
; Must be an application:
|
||||
(cons a (hyg:untag-list (cdr e) al tmps))])
|
||||
(cons a (hyg:untag-list* (cdr e) al tmps))))
|
||||
(hyg:untag-vanilla e al tmps)))]
|
||||
[hyg:untag-list
|
||||
(lambda (ee al tmps)
|
||||
(map (lambda (e)
|
||||
(hyg:untag e al tmps)) ee))]
|
||||
[hyg:untag-list*
|
||||
(lambda (ee al tmps)
|
||||
(let loop ((ee ee))
|
||||
(if (pair? ee)
|
||||
(cons (hyg:untag (car ee) al tmps)
|
||||
(loop (cdr ee)))
|
||||
(hyg:untag ee al tmps))))]
|
||||
[hyg:untag-no-tags
|
||||
(lambda (e al)
|
||||
(cond
|
||||
[(pair? e)
|
||||
(cons (hyg:untag-no-tags (car e) al)
|
||||
(hyg:untag-no-tags (cdr e) al))]
|
||||
[(vector? e)
|
||||
(list->vector
|
||||
(hyg:untag-no-tags (vector->list e) al))]
|
||||
[(not (symbol? e)) e]
|
||||
[(assq e al) => cdr]
|
||||
[else e]))]
|
||||
[hyg:untag-quasiquote
|
||||
(lambda (form al tmps)
|
||||
(let qq ([x form][level 0])
|
||||
(cond
|
||||
[(pair? x)
|
||||
(let ([first (qq (car x) level)])
|
||||
(cond
|
||||
[(and (eq? first 'unquote) (list? x))
|
||||
(let ([rest (cdr x)])
|
||||
(if (or (not (pair? rest))
|
||||
(not (null? (cdr rest))))
|
||||
(raise-syntax-error
|
||||
'unquote
|
||||
"takes exactly one expression"
|
||||
(list 'quasiquote (hyg:untag-no-tags form al)))
|
||||
(if (zero? level)
|
||||
(list 'unquote (hyg:untag (car rest) al tmps))
|
||||
(cons first (qq rest (sub1 level))))))]
|
||||
[(and (eq? first 'quasiquote) (list? x))
|
||||
(cons 'quasiquote (qq (cdr x) (add1 level)))]
|
||||
[(and (eq? first 'unquote-splicing) (list? x))
|
||||
(raise-syntax-error
|
||||
'unquote-splicing
|
||||
"invalid context within quasiquote"
|
||||
(list 'quasiquote (hyg:untag-no-tags form al)))]
|
||||
[(pair? first)
|
||||
(let ([car-first (qq (car first) level)])
|
||||
(if (and (eq? car-first 'unquote-splicing)
|
||||
(list? first))
|
||||
(let ([rest (cdr first)])
|
||||
(if (or (not (pair? rest))
|
||||
(not (null? (cdr rest))))
|
||||
(raise-syntax-error
|
||||
'unquote-splicing
|
||||
"takes exactly one expression"
|
||||
(list 'quasiquote (hyg:untag-no-tags form al)))
|
||||
(list (list 'unquote-splicing
|
||||
(if (zero? level)
|
||||
(hyg:untag (cadr rest) al tmps)
|
||||
(qq (cadr rest) (sub1 level)))
|
||||
(qq (cdr x) level)))))
|
||||
(cons (cons car-first
|
||||
(qq (cdr first) level))
|
||||
(qq (cdr x) level))))]
|
||||
[else
|
||||
(cons first (qq (cdr x) level))]))]
|
||||
[(vector? x)
|
||||
(list->vector
|
||||
(qq (vector->list x) level))]
|
||||
[(box? x)
|
||||
(box (qq (unbox x) level))]
|
||||
[else (hyg:untag-no-tags x al)])))]
|
||||
[hyg:untag-lambda
|
||||
(lambda (formname bvv body al tmps)
|
||||
(let ((tmps2 (append! (hyg:flatten bvv) tmps)))
|
||||
`(,formname ,bvv
|
||||
,@(hyg:untag-list body al tmps2))))]
|
||||
[hyg:untag-letrec
|
||||
(lambda (formname varvals body al tmps)
|
||||
(let ((tmps (append! (map car varvals) tmps)))
|
||||
`(,formname
|
||||
,(map
|
||||
(lambda (varval)
|
||||
`(,(car varval)
|
||||
,(hyg:untag (cadr varval) al tmps)))
|
||||
varvals)
|
||||
,@(hyg:untag-list body al tmps))))]
|
||||
[hyg:untag-let
|
||||
(lambda (formname varvals body al tmps)
|
||||
(let ((tmps2 (append! (map car varvals) tmps)))
|
||||
`(,formname
|
||||
,(map
|
||||
(lambda (varval)
|
||||
`(,(car varval)
|
||||
,(hyg:untag (cadr varval) al tmps)))
|
||||
varvals)
|
||||
,@(hyg:untag-list body al tmps2))))]
|
||||
[hyg:untag-named-let
|
||||
(lambda (formname lname varvals body al tmps)
|
||||
(let ((tmps2 (cons lname (append! (map car varvals) tmps))))
|
||||
`(,formname ,lname
|
||||
,(map
|
||||
(lambda (varval)
|
||||
`(,(car varval)
|
||||
,(hyg:untag (cadr varval) al tmps)))
|
||||
varvals)
|
||||
,@(hyg:untag-list body al tmps2))))]
|
||||
[hyg:untag-let*
|
||||
(lambda (varvals body al tmps)
|
||||
(let ((tmps2 (append! (reverse! (map car varvals)) tmps)))
|
||||
`(let*
|
||||
,(let loop ((varvals varvals)
|
||||
(i (length varvals)))
|
||||
(if (null? varvals) '()
|
||||
(let ((varval (car varvals)))
|
||||
(cons `(,(car varval)
|
||||
,(hyg:untag (cadr varval)
|
||||
al (list-tail tmps2 i)))
|
||||
(loop (cdr varvals) (- i 1))))))
|
||||
,@(hyg:untag-list body al tmps2))))]
|
||||
[hyg:untag-do
|
||||
(lambda (varinistps exit-test body al tmps)
|
||||
(let ((tmps2 (append! (map car varinistps) tmps)))
|
||||
`(do
|
||||
,(map
|
||||
(lambda (varinistp)
|
||||
(let ((var (car varinistp)))
|
||||
`(,var ,@(hyg:untag-list (cdr varinistp) al
|
||||
(cons var tmps)))))
|
||||
varinistps)
|
||||
,(hyg:untag-list exit-test al tmps2)
|
||||
,@(hyg:untag-list body al tmps2))))]
|
||||
[hyg:untag-vanilla
|
||||
(lambda (e al tmps)
|
||||
(cond
|
||||
[(pair? e)
|
||||
(cons (hyg:untag-vanilla (car e) al tmps)
|
||||
(hyg:untag-vanilla (cdr e) al tmps))]
|
||||
[(vector? e)
|
||||
(list->vector
|
||||
(hyg:untag-vanilla (vector->list e) al tmps))]
|
||||
[(not (symbol? e)) e]
|
||||
[(memq e tmps) e]
|
||||
[(assq e al) => cdr]
|
||||
[else e]))]
|
||||
[hyg:flatten
|
||||
(lambda (e)
|
||||
(let loop ((e e) (r '()))
|
||||
(cond
|
||||
[(pair? e) (loop (car e)
|
||||
(loop (cdr e) r))]
|
||||
[(null? e) r]
|
||||
[else (cons e r)])))])
|
||||
(set! -:sr:tag hyg:tag)
|
||||
(set! -:sr:untag hyg:untag)
|
||||
(set! -:sr:flatten hyg:flatten))
|
||||
|
||||
(define -:sr:matches-pattern? 'undefined--:sr:matches-pattern?)
|
||||
(define -:sr:get-bindings 'undefined--:sr:get-bindings)
|
||||
(define -:sr:expand-pattern 'undefined--:sr:expand-pattern)
|
||||
|
||||
(letrec ([mbe:position
|
||||
(lambda (x l)
|
||||
(let loop ((l l) (i 0))
|
||||
(cond ((not (pair? l)) #f)
|
||||
((equal? (car l) x) i)
|
||||
(else (loop (cdr l) (+ i 1))))))]
|
||||
[mbe:append-map
|
||||
(lambda (f l)
|
||||
(let loop ((l l))
|
||||
(if (null? l) '()
|
||||
(append (f (car l)) (loop (cdr l))))))]
|
||||
[mbe:matches-pattern?
|
||||
(lambda (p e k)
|
||||
(cond
|
||||
[(mbe:ellipsis? p)
|
||||
(and (or (null? e) (pair? e))
|
||||
(let* ((p-head (car p))
|
||||
(p-tail (cddr p))
|
||||
(e-head=e-tail (mbe:split-at-ellipsis e p-tail)))
|
||||
(and e-head=e-tail
|
||||
(let ((e-head (car e-head=e-tail))
|
||||
(e-tail (cdr e-head=e-tail)))
|
||||
(and (andmap
|
||||
(lambda (x) (mbe:matches-pattern? p-head x k))
|
||||
e-head)
|
||||
(mbe:matches-pattern? p-tail e-tail k))))))]
|
||||
[(pair? p)
|
||||
(and (pair? e)
|
||||
(mbe:matches-pattern? (car p) (car e) k)
|
||||
(mbe:matches-pattern? (cdr p) (cdr e) k))]
|
||||
[(symbol? p) (if (memq p k) (eq? p e) #t)]
|
||||
[else (equal? p e)]))]
|
||||
[mbe:get-bindings
|
||||
(lambda (p e k)
|
||||
(cond
|
||||
[(mbe:ellipsis? p)
|
||||
(let* ((p-head (car p))
|
||||
(p-tail (cddr p))
|
||||
(e-head=e-tail (mbe:split-at-ellipsis e p-tail))
|
||||
(e-head (car e-head=e-tail))
|
||||
(e-tail (cdr e-head=e-tail)))
|
||||
(cons (cons (mbe:get-ellipsis-nestings p-head k)
|
||||
(map (lambda (x) (mbe:get-bindings p-head x k))
|
||||
e-head))
|
||||
(mbe:get-bindings p-tail e-tail k)))]
|
||||
[(pair? p)
|
||||
(append (mbe:get-bindings (car p) (car e) k)
|
||||
(mbe:get-bindings (cdr p) (cdr e) k))]
|
||||
[(symbol? p)
|
||||
(if (memq p k) '() (list (cons p e)))]
|
||||
[else '()]))]
|
||||
[mbe:expand-pattern
|
||||
(lambda (p r k)
|
||||
(cond
|
||||
[(mbe:ellipsis? p)
|
||||
(append (let* ((p-head (car p))
|
||||
(nestings (mbe:get-ellipsis-nestings p-head k))
|
||||
(rr (mbe:ellipsis-sub-envs nestings r)))
|
||||
(map (lambda (r1)
|
||||
(mbe:expand-pattern p-head (append r1 r) k))
|
||||
rr))
|
||||
(mbe:expand-pattern (cddr p) r k))]
|
||||
[(pair? p)
|
||||
(cons (mbe:expand-pattern (car p) r k)
|
||||
(mbe:expand-pattern (cdr p) r k))]
|
||||
[(symbol? p)
|
||||
(if (memq p k) p
|
||||
(let ((x (assq p r)))
|
||||
(if x (cdr x) p)))]
|
||||
[else p]))]
|
||||
[mbe:get-ellipsis-nestings
|
||||
(lambda (p k)
|
||||
(let sub ((p p))
|
||||
(cond
|
||||
[(mbe:ellipsis? p) (cons (sub (car p)) (sub (cddr p)))]
|
||||
[(pair? p) (append (sub (car p)) (sub (cdr p)))]
|
||||
[(symbol? p) (if (memq p k) '() (list p))]
|
||||
[else '()])))]
|
||||
[mbe:ellipsis-sub-envs
|
||||
(lambda (nestings r)
|
||||
(let ((sub-envs-list
|
||||
(let loop ((r r) (sub-envs-list '()))
|
||||
(if (null? r) (reverse! sub-envs-list)
|
||||
(let ((c (car r)))
|
||||
(loop (cdr r)
|
||||
(if (mbe:contained-in? nestings (car c))
|
||||
(cons (cdr c) sub-envs-list)
|
||||
sub-envs-list)))))))
|
||||
(case (length sub-envs-list)
|
||||
((0) #f)
|
||||
((1) (car sub-envs-list))
|
||||
(else
|
||||
(let loop ((sub-envs-list sub-envs-list) (final-sub-envs '()))
|
||||
(if (ormap null? sub-envs-list) (reverse! final-sub-envs)
|
||||
(loop (map cdr sub-envs-list)
|
||||
(cons (mbe:append-map car sub-envs-list)
|
||||
final-sub-envs))))))))]
|
||||
[mbe:contained-in?
|
||||
(lambda (v y)
|
||||
(if (or (symbol? v) (symbol? y)) (eq? v y)
|
||||
(ormap (lambda (v_i)
|
||||
(ormap (lambda (y_j)
|
||||
(mbe:contained-in? v_i y_j))
|
||||
y))
|
||||
v)))]
|
||||
[mbe:split-at-ellipsis
|
||||
(lambda (e p-tail)
|
||||
(if (null? p-tail) (cons e '())
|
||||
(let ((i (mbe:position (car p-tail) e)))
|
||||
(if i (cons (comlist:butlast e (- (length e) i))
|
||||
(list-tail e i))
|
||||
(error 'mbe:split-at-ellipsis "bad argument in syntax-rules")))))]
|
||||
[mbe:ellipsis?
|
||||
(lambda (x)
|
||||
(and (pair? x) (pair? (cdr x)) (eq? (cadr x) '...)))]
|
||||
[comlist:butlast
|
||||
(lambda (lst n)
|
||||
(letrec ((l (- (length lst) n))
|
||||
(bl (lambda (lst n)
|
||||
(cond ((null? lst) lst)
|
||||
((positive? n)
|
||||
(cons (car lst) (bl (cdr lst) (+ -1 n))))
|
||||
(else '())))))
|
||||
(bl lst (if (negative? n)
|
||||
(error 'butlast "negative argument in syntax-rules: ~s"
|
||||
n)
|
||||
l))))])
|
||||
(set! -:sr:matches-pattern? mbe:matches-pattern?)
|
||||
(set! -:sr:get-bindings mbe:get-bindings)
|
||||
(set! -:sr:expand-pattern mbe:expand-pattern))
|
||||
|
||||
(define make-expander
|
||||
(lambda (who macro-name syn-rules)
|
||||
(if (or (not (pair? syn-rules))
|
||||
(not (eq? (car syn-rules) 'syntax-rules)))
|
||||
(error who "~s not an R5RS macro: ~s"
|
||||
macro-name syn-rules)
|
||||
(let ((keywords (cons macro-name (cadr syn-rules)))
|
||||
(clauses (cddr syn-rules)))
|
||||
`(lambda macro-arg
|
||||
(let ((macro-arg (cons ',macro-name macro-arg))
|
||||
(keywords ',keywords))
|
||||
(cond ,@(map
|
||||
(lambda (clause)
|
||||
(let ([in-pattern (car clause)]
|
||||
[out-pattern (cadr clause)])
|
||||
`((-:sr:matches-pattern? ',in-pattern macro-arg
|
||||
keywords)
|
||||
(let ([tagged-out-pattern+alist
|
||||
(-:sr:tag
|
||||
',out-pattern
|
||||
(append! (-:sr:flatten ',in-pattern)
|
||||
keywords) '())])
|
||||
(-:sr:untag
|
||||
(-:sr:expand-pattern
|
||||
(car tagged-out-pattern+alist)
|
||||
(-:sr:get-bindings ',in-pattern macro-arg
|
||||
keywords)
|
||||
keywords)
|
||||
(cdr tagged-out-pattern+alist)
|
||||
'())))))
|
||||
clauses)
|
||||
(else (error ',macro-name "no matching clause: ~s"
|
||||
',clauses)))))))))
|
||||
|
||||
(define define-syntax
|
||||
(lambda (macro-name syn-rules)
|
||||
(let ([expander (make-expander 'define-syntax macro-name syn-rules)])
|
||||
`(define-macro ,macro-name ,expander)))))
|
||||
8
collects/mzlib/thread.ss
Normal file
8
collects/mzlib/thread.ss
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
|
||||
(require-library "threadu.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:thread^
|
||||
mzlib:thread@)
|
||||
192
collects/mzlib/threadr.ss
Normal file
192
collects/mzlib/threadr.ss
Normal file
|
|
@ -0,0 +1,192 @@
|
|||
|
||||
(unit/sig mzlib:thread^
|
||||
(import)
|
||||
|
||||
#|
|
||||
t accepts a function, f, and creates a thread. It returns the thread and a
|
||||
function, g. When g is applied it passes it's argument to f, and evaluates
|
||||
the call of f in the time of the thread that was created. Calls to g do not
|
||||
block.
|
||||
|#
|
||||
|
||||
(define consumer-thread
|
||||
(case-lambda
|
||||
[(f) (consumer-thread f void)]
|
||||
[(f init)
|
||||
(unless (procedure? f) (raise-type-error 'consumer-thread "procedure" f))
|
||||
(let ([sema (make-semaphore 0)]
|
||||
[protect (make-semaphore 1)]
|
||||
[front-state null]
|
||||
[back-state null])
|
||||
(values
|
||||
(thread
|
||||
(letrec ([loop
|
||||
(lambda ()
|
||||
(semaphore-wait sema)
|
||||
(let ([local-state
|
||||
(begin
|
||||
(semaphore-wait protect)
|
||||
(if (null? back-state)
|
||||
(let ([new-front (reverse front-state)])
|
||||
(set! back-state (cdr new-front))
|
||||
(set! front-state null)
|
||||
(semaphore-post protect)
|
||||
(car new-front))
|
||||
(begin0
|
||||
(car back-state)
|
||||
(set! back-state (cdr back-state))
|
||||
(semaphore-post protect))))])
|
||||
(apply f local-state))
|
||||
(loop))])
|
||||
(lambda ()
|
||||
(init)
|
||||
(loop))))
|
||||
(lambda new-state
|
||||
(let ([num (length new-state)])
|
||||
(unless (procedure-arity-includes? f num)
|
||||
(raise
|
||||
(make-exn:application:arity
|
||||
(format "<procedure-from-consumer-thread>: consumer procedure arity is ~e; provided ~s argument~a"
|
||||
(arity f) num (if (= 1 num) "" "s"))
|
||||
(current-continuation-marks)
|
||||
num
|
||||
(arity f)))))
|
||||
(semaphore-wait protect)
|
||||
(set! front-state (cons new-state front-state))
|
||||
(semaphore-post protect)
|
||||
(semaphore-post sema))))]))
|
||||
|
||||
|
||||
(define (merge-input a b)
|
||||
(or (input-port? a)
|
||||
(raise-type-error 'merge-input "input-port" a))
|
||||
(or (input-port? b)
|
||||
(raise-type-error 'merge-input "input-port" b))
|
||||
(let-values ([(rd wt) (make-pipe)])
|
||||
(let* ([copy1-sema (make-semaphore 500)]
|
||||
[copy2-sema (make-semaphore 500)]
|
||||
[ready1-sema (make-semaphore)]
|
||||
[ready2-sema (make-semaphore)]
|
||||
[check-first? #t]
|
||||
[close-sema (make-semaphore)]
|
||||
[mk-copy (lambda (from to copy-sema ready-sema)
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(semaphore-wait copy-sema)
|
||||
(let ([c (read-char from)])
|
||||
(unless (eof-object? c)
|
||||
(semaphore-post ready-sema)
|
||||
(write-char c to)
|
||||
(loop))))
|
||||
(semaphore-post close-sema)))])
|
||||
(thread (mk-copy a wt copy1-sema ready1-sema))
|
||||
(thread (mk-copy b wt copy2-sema ready2-sema))
|
||||
(thread (lambda ()
|
||||
(semaphore-wait close-sema)
|
||||
(semaphore-wait close-sema)
|
||||
(close-output-port wt)))
|
||||
(make-input-port
|
||||
(lambda () (let ([c (read-char rd)])
|
||||
(unless (eof-object? c)
|
||||
(if (and check-first? (semaphore-try-wait? ready1-sema))
|
||||
(semaphore-post copy1-sema)
|
||||
(if (not (semaphore-try-wait? ready2-sema))
|
||||
; check-first? must be #f
|
||||
(if (semaphore-try-wait? ready1-sema)
|
||||
(semaphore-post copy1-sema)
|
||||
(error 'join "internal error: char from nowhere!"))
|
||||
(semaphore-post copy2-sema)))
|
||||
(set! check-first? (not check-first?)))
|
||||
c))
|
||||
(lambda () (char-ready? rd))
|
||||
(lambda () (close-input-port rd))))))
|
||||
|
||||
(define with-semaphore
|
||||
(lambda (s f)
|
||||
(semaphore-wait s)
|
||||
(begin0 (f)
|
||||
(semaphore-post s))))
|
||||
|
||||
(define semaphore-wait-multiple
|
||||
(case-lambda
|
||||
[(semaphores) (semaphore-wait-multiple semaphores #f #f)]
|
||||
[(semaphores timeout) (semaphore-wait-multiple semaphores timeout #f)]
|
||||
[(semaphores timeout allow-break?)
|
||||
(let ([break-enabled? (or allow-break? (break-enabled))])
|
||||
(parameterize ([break-enabled #f])
|
||||
(for-each
|
||||
(lambda (s)
|
||||
(or (semaphore? s)
|
||||
(raise-type-error 'semaphore-wait-multiple "list of semaphores" semaphores)))
|
||||
semaphores)
|
||||
(or (not timeout) (real? timeout) (>= timeout 0)
|
||||
(raise-type-error 'semaphore-wait-multiple "positive real number" timeout))
|
||||
(let* ([result-l null]
|
||||
[ok? #f]
|
||||
[set-l (make-semaphore 1)]
|
||||
[one-done (make-semaphore)]
|
||||
[threads (let loop ([l semaphores])
|
||||
(if (null? l)
|
||||
null
|
||||
(cons (let ([s (car l)])
|
||||
(thread (lambda ()
|
||||
(let/ec
|
||||
k
|
||||
(current-exception-handler k)
|
||||
(semaphore-wait/enable-break s)
|
||||
(with-semaphore
|
||||
set-l
|
||||
(lambda () (set! result-l
|
||||
(cons s result-l))))
|
||||
(semaphore-post one-done)))))
|
||||
(loop (cdr l)))))]
|
||||
[timer-thread (if timeout
|
||||
(thread (lambda () (sleep timeout) (semaphore-post one-done)))
|
||||
#f)])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
; wait until someone is done
|
||||
((if break-enabled? semaphore-wait/enable-break semaphore-wait) one-done)
|
||||
(set! ok? #t))
|
||||
(lambda ()
|
||||
; tell everyone to stop
|
||||
(for-each (lambda (th) (break-thread th)) threads)
|
||||
(when timer-thread (break-thread timer-thread))
|
||||
; wait until everyone's done
|
||||
(for-each thread-wait threads)
|
||||
; If more that too manay suceeded, repost to the extras
|
||||
(let ([extras (if ok?
|
||||
(if (null? result-l)
|
||||
null
|
||||
(cdr result-l))
|
||||
result-l)])
|
||||
(for-each (lambda (s) (semaphore-post s)) extras))))
|
||||
(if (null? result-l)
|
||||
#f
|
||||
(car result-l)))))]))
|
||||
|
||||
(define dynamic-enable-break
|
||||
(polymorphic
|
||||
(lambda (thunk)
|
||||
(parameterize ([break-enabled #t])
|
||||
(thunk)))))
|
||||
|
||||
(define dynamic-disable-break
|
||||
(polymorphic
|
||||
(lambda (thunk)
|
||||
(parameterize ([break-enabled #f])
|
||||
(thunk)))))
|
||||
|
||||
(define make-single-threader
|
||||
(polymorphic
|
||||
(lambda ()
|
||||
(let ([sema (make-semaphore 1)])
|
||||
(lambda (thunk)
|
||||
(dynamic-wind
|
||||
(lambda () (semaphore-wait sema))
|
||||
thunk
|
||||
(lambda () (semaphore-post sema))))))))
|
||||
|
||||
)
|
||||
|
||||
13
collects/mzlib/threads.ss
Normal file
13
collects/mzlib/threads.ss
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
|
||||
(begin-elaboration-time
|
||||
(require-relative-library "spidey.ss"))
|
||||
|
||||
(define-signature mzlib:thread^
|
||||
(consumer-thread
|
||||
merge-input
|
||||
with-semaphore
|
||||
semaphore-wait-multiple
|
||||
|
||||
dynamic-disable-break
|
||||
dynamic-enable-break
|
||||
make-single-threader))
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user