...
original commit: eef364ac41effca56d689a1923372075bb29624f
This commit is contained in:
Robby Findler
parent
74d1ddf3a2
commit
6cd1f2d48a
|
|
@ -12,7 +12,7 @@
|
|||
(require-relative-library "guiutilss.ss")
|
||||
|
||||
(define-signature framework:prefs-file^
|
||||
(preferences-filename))
|
||||
(get-preferences-filename))
|
||||
|
||||
(define-signature framework:version^
|
||||
(add-spec
|
||||
|
|
|
|||
|
|
@ -207,13 +207,13 @@
|
|||
(message-box
|
||||
"Error saving preferences"
|
||||
(exn-message exn)))])
|
||||
(call-with-output-file prefs-file:preferences-filename
|
||||
(call-with-output-file (prefs-file:get-preferences-filename)
|
||||
(lambda (p)
|
||||
(mzlib:pretty-print:pretty-print
|
||||
(hash-table-map preferences marshall-pref) p))
|
||||
'truncate 'text)))))
|
||||
|
||||
(define (for-each-pref-in-file parse-pref prefs-file:preferences-filename)
|
||||
(define (for-each-pref-in-file parse-pref preferences-filename)
|
||||
(let/ec k
|
||||
(let ([err
|
||||
(lambda (input msg)
|
||||
|
|
@ -228,7 +228,7 @@
|
|||
(string-length ell)))
|
||||
ell))])
|
||||
(format "found bad pref in ~a: ~a~n~a"
|
||||
prefs-file:preferences-filename msg s2))))])
|
||||
preferences-filename msg s2))))])
|
||||
(let ([input (with-handlers
|
||||
([(lambda (exn) #t)
|
||||
(lambda (exn)
|
||||
|
|
@ -237,7 +237,7 @@
|
|||
(format "Error reading preferences~n~a"
|
||||
(exn-message exn)))
|
||||
(k #f))])
|
||||
(call-with-input-file prefs-file:preferences-filename
|
||||
(call-with-input-file (prefs-file:get-preferences-filename)
|
||||
read
|
||||
'text))])
|
||||
(if (eof-object? input)
|
||||
|
|
@ -294,7 +294,7 @@
|
|||
|
||||
;; read : -> void
|
||||
(define (-read)
|
||||
(read-from-file-to-ht prefs-file:preferences-filename preferences))
|
||||
(read-from-file-to-ht (prefs-file:get-preferences-filename) preferences))
|
||||
|
||||
|
||||
;; read in the saved defaults. These should override the
|
||||
|
|
|
|||
|
|
@ -1,180 +0,0 @@
|
|||
|
||||
(unit/sig mzlib:restart^
|
||||
(import mzlib:command-line^)
|
||||
|
||||
(define (restart-mzscheme init-argv adjust-flag-table argv init-namespace)
|
||||
(let* ([result #t]
|
||||
[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 (find-system-path 'exec-file)])
|
||||
(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/ec k
|
||||
(exit-handler
|
||||
(lambda (status)
|
||||
(set! result status)
|
||||
(k #f)))
|
||||
(let/ec escape
|
||||
(for-each
|
||||
(lambda (e)
|
||||
(with-handlers ([void (lambda (e)
|
||||
(print-error e)
|
||||
(set! result #f)
|
||||
(escape #f))])
|
||||
(eval (read (open-input-string e)))))
|
||||
exprs))
|
||||
(unless no-rep?
|
||||
(read-eval-print-loop)
|
||||
(set! result #t))))))))
|
||||
`("arg"))
|
||||
result)))
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
|
||||
(begin-elaboration-time
|
||||
(require-library "cmdlines.ss"))
|
||||
|
||||
(define-signature mzlib:restart^
|
||||
(restart-mzscheme))
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
|
||||
(require-library "restarts.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "refer.ss"))
|
||||
|
||||
(define mzlib:restart@ (require-library-unit/sig "restartr.ss"))
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
|
||||
(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)
|
||||
|
||||
|
||||
|
|
@ -1,146 +0,0 @@
|
|||
|
||||
(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)))))
|
||||
|
||||
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
|
||||
(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))
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
|
||||
(require-library "stringu.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:string^
|
||||
mzlib:string@)
|
||||
|
||||
|
|
@ -1,104 +0,0 @@
|
|||
(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)))))
|
||||
)
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
|
||||
(define-signature mzlib:string^
|
||||
(string-lowercase!
|
||||
string-uppercase!
|
||||
eval-string
|
||||
read-from-string
|
||||
read-from-string-all
|
||||
expr->string
|
||||
newline-string
|
||||
regexp-match-exact?))
|
||||
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
|
||||
(require-library "strings.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "refer.ss"))
|
||||
|
||||
(define mzlib:string@ (require-library-unit/sig "stringr.ss"))
|
||||
|
|
@ -1,22 +0,0 @@
|
|||
|
||||
(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)
|
||||
|
|
@ -1,429 +0,0 @@
|
|||
; 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)))))
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
|
||||
(require-library "threadu.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:thread^
|
||||
mzlib:thread@)
|
||||
|
|
@ -1,192 +0,0 @@
|
|||
|
||||
(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))))))))
|
||||
|
||||
)
|
||||
|
||||
|
|
@ -1,13 +0,0 @@
|
|||
|
||||
(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))
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
|
||||
(require-library "threads.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "refer.ss"))
|
||||
|
||||
(define mzlib:thread@ (require-library-unit/sig "threadr.ss"))
|
||||
|
|
@ -1,273 +0,0 @@
|
|||
; Time-stamp: <97/08/19 15:07:32 shriram>
|
||||
; Time-stamp: <97/07/12 12:44:01 shriram>
|
||||
|
||||
; Differences from the Chez implementation:
|
||||
|
||||
; - The code does not respect tail-calls.
|
||||
; - If the library is loaded more than once, especially in the middle
|
||||
; of a trace, the behavior is not well-defined.
|
||||
|
||||
(define-signature mzlib:trace^
|
||||
(-:trace-level -:trace-print-args -:trace-print-results
|
||||
-:trace-table
|
||||
-:make-traced-entry -:traced-entry-original-proc -:traced-entry-trace-proc
|
||||
trace untrace))
|
||||
|
||||
(begin-elaboration-time (require-library "prettyu.ss"))
|
||||
|
||||
(begin-elaboration-time
|
||||
(define mzlib:trace@
|
||||
(unit/sig mzlib:trace^
|
||||
(import mzlib:pretty-print^)
|
||||
|
||||
(define max-dash-space-depth 10)
|
||||
(define number-nesting-depth 6)
|
||||
|
||||
(define as-spaces
|
||||
(lambda (s)
|
||||
(let ((n (string-length s)))
|
||||
(apply string-append
|
||||
(let loop ((k n))
|
||||
(if (zero? k) '("")
|
||||
(cons " " (loop (sub1 k)))))))))
|
||||
|
||||
(define-struct prefix-entry (for-first for-rest))
|
||||
|
||||
(define prefixes (make-vector 20 #f))
|
||||
(define prefix-vector-length 20)
|
||||
|
||||
(define lookup-prefix
|
||||
(lambda (n)
|
||||
(and (< n prefix-vector-length)
|
||||
(vector-ref prefixes n))))
|
||||
|
||||
(define insert-prefix
|
||||
(lambda (n first rest)
|
||||
(if (>= n prefix-vector-length)
|
||||
(let ((v (make-vector (* 2 prefix-vector-length) #f)))
|
||||
(let loop ((k 0))
|
||||
(when (< k prefix-vector-length)
|
||||
(vector-set! v k (vector-ref prefixes k))
|
||||
(loop (add1 k))))
|
||||
(set! prefixes v)
|
||||
(set! prefix-vector-length (* 2 prefix-vector-length))
|
||||
(insert-prefix n first rest))
|
||||
(vector-set! prefixes n (make-prefix-entry first rest)))))
|
||||
|
||||
(define construct-prefixes
|
||||
(lambda (level)
|
||||
(let loop ((n level)
|
||||
(first '("|"))
|
||||
(rest '(" ")))
|
||||
(if (>= n max-dash-space-depth)
|
||||
(let-values (((pre-first pre-rest)
|
||||
(build-prefixes number-nesting-depth)))
|
||||
(let ((s (number->string level)))
|
||||
(values
|
||||
(apply string-append
|
||||
(cons pre-first (cons "[" (cons s (cons "]" '())))))
|
||||
(apply string-append
|
||||
(cons pre-rest (cons " " (cons (as-spaces s)
|
||||
(cons " " '()))))))))
|
||||
(cond
|
||||
((= n 0) (values (apply string-append (reverse first))
|
||||
(apply string-append (reverse rest))))
|
||||
((= n 1) (loop (- n 1)
|
||||
(cons '" " first)
|
||||
(cons '" " rest)))
|
||||
(else (loop (- n 2)
|
||||
(cons " |" first)
|
||||
(cons " " rest))))))))
|
||||
|
||||
(define build-prefixes
|
||||
(lambda (level)
|
||||
(let ((p (lookup-prefix level)))
|
||||
(if p
|
||||
(values (prefix-entry-for-first p)
|
||||
(prefix-entry-for-rest p))
|
||||
(let-values (((first rest)
|
||||
(construct-prefixes level)))
|
||||
(insert-prefix level first rest)
|
||||
(values first rest))))))
|
||||
|
||||
(define -:trace-level (make-parameter -1))
|
||||
|
||||
(define -:trace-print-args
|
||||
(lambda (name args)
|
||||
(let-values (((first rest)
|
||||
(build-prefixes (-:trace-level))))
|
||||
(parameterize ((pretty-print-print-line
|
||||
(lambda (n port offset width)
|
||||
(display
|
||||
(if n
|
||||
(if (zero? n) first
|
||||
(format "~n~a" rest))
|
||||
(format "~n"))
|
||||
port)
|
||||
(if n
|
||||
(if (zero? n)
|
||||
(string-length first)
|
||||
(string-length rest))
|
||||
0))))
|
||||
(pretty-print (cons name args))))))
|
||||
|
||||
(define -:trace-print-results
|
||||
(lambda (name results)
|
||||
(let-values (((first rest)
|
||||
(build-prefixes (-:trace-level))))
|
||||
(parameterize ((pretty-print-print-line
|
||||
(lambda (n port offset width)
|
||||
(display
|
||||
(if n
|
||||
(if (zero? n) first
|
||||
(format "~n~a" rest))
|
||||
(format "~n"))
|
||||
port)
|
||||
(if n
|
||||
(if (zero? n)
|
||||
(string-length first)
|
||||
(string-length rest))
|
||||
0))))
|
||||
(cond
|
||||
((null? results)
|
||||
(pretty-display "*** no values ***"))
|
||||
((null? (cdr results))
|
||||
(pretty-print (car results)))
|
||||
(else
|
||||
(pretty-print (car results))
|
||||
(parameterize ((pretty-print-print-line
|
||||
(lambda (n port offset width)
|
||||
(display
|
||||
(if n
|
||||
(if (zero? n) rest
|
||||
(format "~n~a" rest))
|
||||
(format "~n"))
|
||||
port)
|
||||
(if n
|
||||
(string-length rest)
|
||||
0))))
|
||||
(for-each pretty-print (cdr results)))))))))
|
||||
|
||||
(define-struct traced-entry (original-proc trace-proc))
|
||||
|
||||
(define -:make-traced-entry make-traced-entry)
|
||||
(define -:traced-entry-original-proc traced-entry-original-proc)
|
||||
(define -:traced-entry-trace-proc traced-entry-trace-proc)
|
||||
|
||||
(define -:trace-table
|
||||
(make-hash-table))
|
||||
|
||||
(define trace
|
||||
(lambda ids
|
||||
(let loop ((ids ids))
|
||||
(unless (null? ids)
|
||||
(unless (symbol? (car ids))
|
||||
(error 'trace "~s not a name" (car ids)))
|
||||
(loop (cdr ids))))
|
||||
`(#%begin
|
||||
,@(map
|
||||
(lambda (id)
|
||||
`(#%with-handlers ((#%exn:variable?
|
||||
(#%lambda (exn)
|
||||
(#%if (#%eq? (#%exn:variable-id exn) ',id)
|
||||
(#%error 'trace
|
||||
"~s is not bound" ',id)
|
||||
(#%raise exn)))))
|
||||
(#%let ((global (#%global-defined-value ',id)))
|
||||
(#%unless (#%procedure? global)
|
||||
(#%error 'trace
|
||||
"the top-level value of ~s is not a procedure" ',id)))))
|
||||
ids)
|
||||
,@(map
|
||||
(lambda (id)
|
||||
(let ((traced-name (string->symbol
|
||||
(string-append "traced-"
|
||||
(symbol->string id))))
|
||||
(table-entry (gensym 'table-entry))
|
||||
(real-value (gensym 'real-value))
|
||||
(global-value (gensym 'global-value)))
|
||||
`(#%let ((,global-value (#%global-defined-value ',id)))
|
||||
(#%let ((,table-entry (#%hash-table-get -:trace-table ',id
|
||||
(#%lambda () #f))))
|
||||
(#%unless (#%and ,table-entry
|
||||
(#%eq? ,global-value
|
||||
(-:traced-entry-trace-proc ,table-entry)))
|
||||
(#%let* ((,real-value ,global-value)
|
||||
(,traced-name
|
||||
(#%lambda args
|
||||
(#%dynamic-wind
|
||||
(lambda ()
|
||||
(-:trace-level
|
||||
(#%add1 (-:trace-level))))
|
||||
(lambda ()
|
||||
(-:trace-print-args ',id args)
|
||||
(#%call-with-values
|
||||
(#%lambda ()
|
||||
(#%apply ,real-value args))
|
||||
(#%lambda results
|
||||
(flush-output)
|
||||
(-:trace-print-results ',id
|
||||
results)
|
||||
(#%apply #%values results))))
|
||||
(lambda ()
|
||||
(-:trace-level
|
||||
(#%sub1 (-:trace-level))))))))
|
||||
(#%hash-table-put! -:trace-table ',id
|
||||
(-:make-traced-entry ,real-value ,traced-name))
|
||||
(#%global-defined-value ',id ,traced-name)))))))
|
||||
ids)
|
||||
(#%quote ,ids))))
|
||||
|
||||
(define untrace
|
||||
(lambda ids
|
||||
(let loop ((ids ids))
|
||||
(unless (null? ids)
|
||||
(unless (symbol? (car ids))
|
||||
(error 'untrace "~s not an identifier" (car ids)))
|
||||
(loop (cdr ids)))
|
||||
`(#%apply #%append
|
||||
(#%list
|
||||
,@(map (lambda (id)
|
||||
`(let ((entry (#%hash-table-get -:trace-table
|
||||
',id (#%lambda () #f))))
|
||||
(#%if (#%and entry
|
||||
(#%eq? (#%global-defined-value ',id)
|
||||
(-:traced-entry-trace-proc entry)))
|
||||
(#%begin
|
||||
(#%hash-table-put! -:trace-table
|
||||
',id #f)
|
||||
(#%global-defined-value ',id
|
||||
(-:traced-entry-original-proc entry))
|
||||
(#%list ',id))
|
||||
'())))
|
||||
ids))))))
|
||||
|
||||
)))
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(begin-elaboration-time
|
||||
(define-values/invoke-unit/sig mzlib:trace^
|
||||
(compound-unit/sig
|
||||
(import)
|
||||
(link
|
||||
(PRETTY : mzlib:pretty-print^
|
||||
(mzlib:pretty-print@))
|
||||
(TRACE : mzlib:trace^
|
||||
(mzlib:trace@ PRETTY)))
|
||||
(export
|
||||
(open TRACE)))
|
||||
#f))
|
||||
|
||||
(define-macro trace trace)
|
||||
(define-macro untrace untrace)
|
||||
|
||||
(begin-elaboration-time
|
||||
(keyword-name '-:trace-print-args)
|
||||
(keyword-name '-:trace-print-results)
|
||||
(keyword-name '-:trace-table)
|
||||
(keyword-name '-:make-traced-entry)
|
||||
(keyword-name '-:traced-entry-original-proc)
|
||||
(keyword-name '-:traced-entry-trace-proc))
|
||||
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
|
||||
(invoke-unit/sig (require-relative-library "traceldr.ss"))
|
||||
|
|
@ -1,49 +0,0 @@
|
|||
|
||||
(unit/sig
|
||||
()
|
||||
(import)
|
||||
(let ([load (current-load)]
|
||||
[load-extension (current-load-extension)]
|
||||
[ep (current-error-port)]
|
||||
[tab ""])
|
||||
(let ([mk-chain
|
||||
(lambda (load)
|
||||
(lambda (filename)
|
||||
(fprintf ep
|
||||
"~aloading ~a at ~a~n"
|
||||
tab filename (current-process-milliseconds))
|
||||
(begin0
|
||||
(let ([s tab])
|
||||
(dynamic-wind
|
||||
(lambda () (set! tab (string-append " " tab)))
|
||||
(lambda ()
|
||||
(if (regexp-match "_loader" filename)
|
||||
(let ([f (load filename)])
|
||||
(lambda (sym)
|
||||
(fprintf ep
|
||||
"~atrying ~a's ~a~n" tab filename sym)
|
||||
(let ([loader (f sym)])
|
||||
(and loader
|
||||
(lambda ()
|
||||
(fprintf ep
|
||||
"~astarting ~a's ~a at ~a~n"
|
||||
tab filename sym
|
||||
(current-process-milliseconds))
|
||||
(let ([s tab])
|
||||
(begin0
|
||||
(dynamic-wind
|
||||
(lambda () (set! tab (string-append " " tab)))
|
||||
(lambda () (loader))
|
||||
(lambda () (set! tab s)))
|
||||
(fprintf ep
|
||||
"~adone ~a's ~a at ~a~n"
|
||||
tab filename sym
|
||||
(current-process-milliseconds)))))))))
|
||||
(load filename)))
|
||||
(lambda () (set! tab s))))
|
||||
(fprintf ep
|
||||
"~adone ~a at ~a~n"
|
||||
tab filename (current-process-milliseconds)))))])
|
||||
(current-load (mk-chain load))
|
||||
(current-load-extension (mk-chain load-extension)))))
|
||||
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
|
||||
(require-library "transcru.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:transcript^
|
||||
mzlib:transcript@)
|
||||
|
|
@ -1,60 +0,0 @@
|
|||
|
||||
(unit/sig mzlib:transcript^
|
||||
(import)
|
||||
|
||||
(define-values (transcript-on transcript-off)
|
||||
(let ([in #f]
|
||||
[out #f]
|
||||
[err #f]
|
||||
[tee-out (lambda (p p2)
|
||||
(make-output-port
|
||||
(lambda (s)
|
||||
(display s p)
|
||||
(display s p2)
|
||||
(flush-output p)
|
||||
(flush-output p2))
|
||||
void))]
|
||||
[tee-in (lambda (in out)
|
||||
(let ([s null])
|
||||
(make-input-port
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(if (null? s)
|
||||
(begin
|
||||
(let loop ()
|
||||
(set! s (cons (read-char in) s))
|
||||
(when (char-ready? in)
|
||||
(loop)))
|
||||
(set! s (reverse! s))
|
||||
(for-each
|
||||
(lambda (c) (unless (eof-object? c) (write-char c out)))
|
||||
s)
|
||||
(flush-output out)
|
||||
(loop))
|
||||
(begin0
|
||||
(car s)
|
||||
(set! s (cdr s))))))
|
||||
(lambda () (char-ready? in))
|
||||
void
|
||||
(lambda () (peek-char in)))))])
|
||||
(values
|
||||
(lambda (file)
|
||||
(when in
|
||||
(error 'transcript-on "transcript is already on"))
|
||||
(let ([p (open-output-file file)])
|
||||
(set! in (current-input-port))
|
||||
(set! out (current-output-port))
|
||||
(set! err (current-error-port))
|
||||
(current-output-port (tee-out out p))
|
||||
(current-error-port (tee-out err p))
|
||||
(current-input-port (tee-in in p))))
|
||||
(lambda ()
|
||||
(unless in
|
||||
(error 'transcript-on "transcript is not on"))
|
||||
(current-input-port in)
|
||||
(current-output-port out)
|
||||
(current-error-port err)
|
||||
(set! in #f)
|
||||
(set! out #f)
|
||||
(set! err #f))))))
|
||||
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
|
||||
(define-signature mzlib:transcript^
|
||||
(transcript-on
|
||||
transcript-off))
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
|
||||
(require-library "transcrs.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "refer.ss"))
|
||||
|
||||
(define mzlib:transcript@ (require-library-unit/sig "transcrr.ss"))
|
||||
|
||||
|
|
@ -1,27 +0,0 @@
|
|||
This directory contains a few example MzScheme extensions implemented
|
||||
in C:
|
||||
|
||||
* hello.c - returns the string "Hello, World!". Demonstrates creating
|
||||
a Scheme value.
|
||||
|
||||
* fmod.c - defines the `fmod' procedure, which calculates modulo on
|
||||
floating-point numbers. Demonstrates creating Scheme procedures
|
||||
from C and adding top-level definitions.
|
||||
|
||||
* curses.c - links MzScheme to the curses library. Demonstrates more
|
||||
procedures and definitions, a little more type dispatching, and
|
||||
returning multiple values.
|
||||
|
||||
* makeadder.c - defines `make-adder', whch takes a number and returns
|
||||
a procedure that takes another number to add to it. Demonstrates
|
||||
closure creation in C, getting Scheme global values, and calling
|
||||
Scheme procedures from C.
|
||||
|
||||
* bitmatrix.c - implements two-dimentional bit matrixes with some
|
||||
operations. Demonstrates defining a new Scheme data type, data
|
||||
allocation, fancy integer type checking, general exception raising,
|
||||
and registering static variables.
|
||||
|
||||
* helloprint.c - prints "Hello, World!" directly to the current
|
||||
output port rather than relying on the read-eval-print-loop.
|
||||
Demonstrates using built-in Scheme parameter values from C.
|
||||
|
|
@ -1,294 +0,0 @@
|
|||
/*
|
||||
|
||||
This extension Defines a new type of Scheme data: a two-dimensional
|
||||
matrix of bits.
|
||||
|
||||
A client using this extension would look something like this:
|
||||
|
||||
(load-extension "bitmatrix.so")
|
||||
(define bm (make-bit-matrix 1000 1000))
|
||||
...
|
||||
(bit-matrix-set! bm 500 500 #t)
|
||||
...
|
||||
(if (bit-matrix-get bm 500 500) ...)
|
||||
...
|
||||
|
||||
*/
|
||||
|
||||
#include "escheme.h"
|
||||
|
||||
/* Instances of this Bitmatrix structure will be the Scheme bit matirx
|
||||
values: */
|
||||
typedef struct {
|
||||
Scheme_Type type; /* Every Scheme value starts with a type tag. The
|
||||
format for the rest of the structure is
|
||||
anything we want it to be. */
|
||||
unsigned long w, h, l; /* l = w rounded to multiple of LONG_SIZE */
|
||||
unsigned long *matrix;
|
||||
} Bitmatrix;
|
||||
|
||||
/* We'll get some Scheme primitives so we can calculate with numbers
|
||||
taht are potentially bignums: */
|
||||
static Scheme_Object *mult, *add, *sub, *modulo, *neg;
|
||||
|
||||
/* The type tag for bit matrixes, initialized with scheme_make_type */
|
||||
static Scheme_Type bitmatrix_type;
|
||||
|
||||
#define LONG_SIZE 32
|
||||
#define LOG_LONG_SIZE 5
|
||||
#define LONG_SIZE_PER_BYTE 4
|
||||
|
||||
# define FIND_BIT(p) (1 << (p & (LONG_SIZE - 1)))
|
||||
|
||||
/* Helper function to check whether an integer (fixnum or bignum) is
|
||||
negative: */
|
||||
static int negative(Scheme_Object *o)
|
||||
{
|
||||
return SCHEME_TRUEP(_scheme_apply(neg, 1, &o));
|
||||
}
|
||||
|
||||
/* Scheme procedure to make a bit matrix: */
|
||||
Scheme_Object *make_bit_matrix(int argc, Scheme_Object **argv)
|
||||
{
|
||||
Scheme_Object *size, *rowlength, *a[2];
|
||||
unsigned long w, h, s, l;
|
||||
Bitmatrix *bm;
|
||||
|
||||
/* Really fancy: we allow any kind of positive integer for
|
||||
specifying the size of a bit matrix. If we get a bignum (or the
|
||||
resulting matrix size is a bignum), we'll signal an out-of-memory
|
||||
exception. */
|
||||
if ((!SCHEME_INTP(argv[0]) && !SCHEME_BIGNUMP(argv[0]))
|
||||
|| negative(argv[0]))
|
||||
scheme_wrong_type("make-bit-matrix", "positive integer", 0, argc, argv);
|
||||
if ((!SCHEME_INTP(argv[1]) && !SCHEME_BIGNUMP(argv[1]))
|
||||
|| (negative(argv[1])))
|
||||
scheme_wrong_type("make-bit-matrix", "positive integer", 1, argc, argv);
|
||||
|
||||
a[0] = argv[0];
|
||||
a[1] = scheme_make_integer(LONG_SIZE - 1);
|
||||
/* Apply the Scheme `add' procedure to argv[0] and argv[1]. Note the
|
||||
"_" in "_scheme_apply"; that's a lot faster than "scheme_apply",
|
||||
and we know that no continuation jumps will occur (although it
|
||||
would be fine if one did. */
|
||||
a[0] = _scheme_apply(add, 2, a);
|
||||
a[1] = scheme_make_integer(LONG_SIZE);
|
||||
a[1] = _scheme_apply(modulo, 2, a);
|
||||
a[0] = _scheme_apply(sub, 2, a);
|
||||
rowlength = a[0];
|
||||
a[1] = argv[1];
|
||||
size = _scheme_apply(mult, 2, a);
|
||||
if (SCHEME_BIGNUMP(size))
|
||||
/* Use scheme_raise_exn to raise exceptions. The first argument
|
||||
describes the tye of the exception. After an exception-specific
|
||||
number of Scheme values (none in this case), the rest of the
|
||||
arguments are like printf. */
|
||||
scheme_raise_exn(MZEXN_MISC_OUT_OF_MEMORY, "make-bit-matrix: out of memory");
|
||||
|
||||
s = SCHEME_INT_VAL(size);
|
||||
w = SCHEME_INT_VAL(argv[0]);
|
||||
h = SCHEME_INT_VAL(argv[1]);
|
||||
l = SCHEME_INT_VAL(rowlength);
|
||||
|
||||
/* Malloc the bit matrix structure. Since we use scheme_malloc, the
|
||||
bit matrix value is GC-able. */
|
||||
bm = (Bitmatrix *)scheme_malloc(sizeof(Bitmatrix));
|
||||
bm->type = bitmatrix_type;
|
||||
|
||||
/* Try to allocate the bit matrix. Handle failure gracefully. Note
|
||||
that we use scheme_malloc_atomic since the allocated memory will
|
||||
never contain pointers to GC-allocated memory. */
|
||||
s = ((s + LONG_SIZE - 1) >> LOG_LONG_SIZE);
|
||||
bm->matrix = (unsigned long *)scheme_malloc_fail_ok(scheme_malloc_atomic,
|
||||
sizeof(long) * s);
|
||||
if (!bm->matrix)
|
||||
scheme_raise_exn(MZEXN_MISC_OUT_OF_MEMORY, "make-bit-matrix: out of memory");
|
||||
|
||||
bm->w = w;
|
||||
bm->h = h;
|
||||
bm->l = l;
|
||||
|
||||
/* Init matirx to all 0s: */
|
||||
while (s--)
|
||||
bm->matrix[s] = 0;
|
||||
|
||||
return (Scheme_Object *)bm;
|
||||
}
|
||||
|
||||
/* Internal utility function for error-checking with a fancy error
|
||||
message: */
|
||||
static void range_check_one(char *name, char *which,
|
||||
int l, int h, int startpos,
|
||||
int argc, Scheme_Object **argv)
|
||||
{
|
||||
int bad1;
|
||||
|
||||
if (SCHEME_BIGNUMP(argv[startpos])) {
|
||||
bad1 = 1;
|
||||
} else {
|
||||
int v = SCHEME_INT_VAL(argv[startpos]);
|
||||
bad1 = ((v < l) || (v > h));
|
||||
}
|
||||
|
||||
if (bad1) {
|
||||
/* A mismatch exception requires one Scheme value, so we provide
|
||||
it before the printf string: */
|
||||
scheme_raise_exn(MZEXN_APPLICATION_MISMATCH,
|
||||
argv[startpos],
|
||||
"%s: %s index %s is not in the range [%d,%d]%s",
|
||||
name, which,
|
||||
scheme_make_provided_string(argv[startpos], 1, NULL),
|
||||
l, h,
|
||||
scheme_make_args_string("other ", startpos, argc, argv));
|
||||
}
|
||||
}
|
||||
|
||||
/* Internal utility function that implements most of the work of the
|
||||
get- and set- Scheme procedures: */
|
||||
static Scheme_Object *do_bit_matrix(char *name, int get, int argc, Scheme_Object **argv)
|
||||
{
|
||||
Bitmatrix *bm;
|
||||
unsigned long x, y, p, v, m;
|
||||
|
||||
if (SCHEME_TYPE(argv[0]) != bitmatrix_type)
|
||||
scheme_wrong_type(name, "bit-matrix", 0, argc, argv);
|
||||
if (!SCHEME_INTP(argv[1]) && !SCHEME_BIGNUMP(argv[1]))
|
||||
scheme_wrong_type(name, "integer", 1, argc, argv);
|
||||
if (!SCHEME_INTP(argv[2]) && !SCHEME_BIGNUMP(argv[2]))
|
||||
scheme_wrong_type(name, "integer", 2, argc, argv);
|
||||
|
||||
/* After checking that argv[0] has te bitmatrix_type tag, we can safely perform
|
||||
a cast to Bitmatrix*: */
|
||||
bm = (Bitmatrix *)argv[0];
|
||||
|
||||
range_check_one(name, "first", 0, bm->w - 1, 1, argc, argv);
|
||||
range_check_one(name, "second", 0, bm->h - 1, 2, argc, argv);
|
||||
|
||||
x = SCHEME_INT_VAL(argv[1]);
|
||||
y = SCHEME_INT_VAL(argv[2]);
|
||||
|
||||
p = y * bm->l + x;
|
||||
m = FIND_BIT(p);
|
||||
v = bm->matrix[p >> LOG_LONG_SIZE];
|
||||
if (get) {
|
||||
return (v & m) ? scheme_true : scheme_false;
|
||||
} else {
|
||||
if (SCHEME_TRUEP(argv[3]))
|
||||
bm->matrix[p >> LOG_LONG_SIZE] = (v | m);
|
||||
else
|
||||
bm->matrix[p >> LOG_LONG_SIZE] = (v - (v & m));
|
||||
return scheme_void;
|
||||
}
|
||||
}
|
||||
|
||||
/* Scheme procedure: get a bit from the matrix */
|
||||
Scheme_Object *bit_matrix_get(int argc, Scheme_Object **argv)
|
||||
{
|
||||
return do_bit_matrix("bit-matrix-get", 1, argc, argv);
|
||||
}
|
||||
|
||||
/* Scheme procedure: set a bit in the matrix */
|
||||
Scheme_Object *bit_matrix_set(int argc, Scheme_Object **argv)
|
||||
{
|
||||
return do_bit_matrix("bit-matrix-set!", 0, argc, argv);
|
||||
}
|
||||
|
||||
/* Scheme procedure: invert the whole matrix */
|
||||
Scheme_Object *bit_matrix_invert(int argc, Scheme_Object **argv)
|
||||
{
|
||||
Bitmatrix *bm;
|
||||
unsigned long i;
|
||||
|
||||
if (SCHEME_TYPE(argv[0]) != bitmatrix_type)
|
||||
scheme_wrong_type("bit-matrix-invert!", "bit-matrix", 0, argc, argv);
|
||||
|
||||
bm = (Bitmatrix *)argv[0];
|
||||
|
||||
i = (bm->l * bm->h) >> LOG_LONG_SIZE;
|
||||
while (i--)
|
||||
bm->matrix[i] = ~bm->matrix[i];
|
||||
|
||||
return scheme_void;
|
||||
}
|
||||
|
||||
/* Scheme procedure: clear the whole matrix */
|
||||
Scheme_Object *bit_matrix_clear(int argc, Scheme_Object **argv)
|
||||
{
|
||||
char *name = "bit-matrix-clear!";
|
||||
Bitmatrix *bm;
|
||||
unsigned long i;
|
||||
|
||||
if (SCHEME_TYPE(argv[0]) != bitmatrix_type)
|
||||
scheme_wrong_type(name, "bit-matrix", 0, argc, argv);
|
||||
|
||||
bm = (Bitmatrix *)argv[0];
|
||||
|
||||
i = (bm->l * bm->h) >> LOG_LONG_SIZE;
|
||||
while (i--)
|
||||
bm->matrix[i] = 0;
|
||||
|
||||
return scheme_void;
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_reload(Scheme_Env *env)
|
||||
{
|
||||
/* Define our new primitives: */
|
||||
|
||||
scheme_add_global("make-bit-matrix",
|
||||
scheme_make_prim_w_arity(make_bit_matrix,
|
||||
"make-bit-matrix",
|
||||
2, 2),
|
||||
env);
|
||||
|
||||
scheme_add_global("bit-matrix-get",
|
||||
scheme_make_prim_w_arity(bit_matrix_get,
|
||||
"bit-matrix-get",
|
||||
3, 3),
|
||||
env);
|
||||
|
||||
scheme_add_global("bit-matrix-set!",
|
||||
scheme_make_prim_w_arity(bit_matrix_set,
|
||||
"bit-matrix-set!",
|
||||
4, 4),
|
||||
env);
|
||||
|
||||
scheme_add_global("bit-matrix-invert!",
|
||||
scheme_make_prim_w_arity(bit_matrix_invert,
|
||||
"bit-matrix-invert!",
|
||||
1, 1),
|
||||
env);
|
||||
|
||||
scheme_add_global("bit-matrix-clear!",
|
||||
scheme_make_prim_w_arity(bit_matrix_clear,
|
||||
"bit-matrix-clear!",
|
||||
1, 1),
|
||||
env);
|
||||
|
||||
return scheme_void;
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_initialize(Scheme_Env *env)
|
||||
{
|
||||
bitmatrix_type = scheme_make_type("<bit-matrix>");
|
||||
|
||||
/* Get some Scheme primitives. Conservative garbage collection sees
|
||||
any local variables we use within a function, but we have to register
|
||||
static variables: */
|
||||
|
||||
scheme_register_extension_global(&mult, sizeof(Scheme_Object*));
|
||||
mult = scheme_lookup_global(scheme_intern_symbol("#%*"), env);
|
||||
|
||||
scheme_register_extension_global(&add, sizeof(Scheme_Object*));
|
||||
add = scheme_lookup_global(scheme_intern_symbol("#%+"), env);
|
||||
|
||||
scheme_register_extension_global(&sub, sizeof(Scheme_Object*));
|
||||
sub = scheme_lookup_global(scheme_intern_symbol("#%-"), env);
|
||||
|
||||
scheme_register_extension_global(&modulo, sizeof(Scheme_Object*));
|
||||
modulo = scheme_lookup_global(scheme_intern_symbol("#%modulo"), env);
|
||||
|
||||
scheme_register_extension_global(&neg, sizeof(Scheme_Object*));
|
||||
neg = scheme_lookup_global(scheme_intern_symbol("#%negative?"), env);
|
||||
|
||||
return scheme_reload(env);
|
||||
}
|
||||
|
|
@ -1,23 +0,0 @@
|
|||
|
||||
; Uses the curses.so extension. Run with
|
||||
; mzscheme -r curses-demo.ss
|
||||
|
||||
; To get append-extension-suffix, shich add .so or .ddl, as
|
||||
; approrpiate for the current platform:
|
||||
(require-library "file.ss" "dynext")
|
||||
|
||||
; Load the curses extension
|
||||
(load-extension (append-extension-suffix "curses"))
|
||||
|
||||
; Screen is initialize. Let's go!
|
||||
(move 10 10)
|
||||
(put "Hello, World!")
|
||||
(put #\newline)
|
||||
(put "Hit any key to continue.")
|
||||
(refresh)
|
||||
|
||||
(get)
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,124 +0,0 @@
|
|||
/*
|
||||
Extension that uses the curses library.
|
||||
|
||||
Link the extension to the curses library like this:
|
||||
mzc --ld hello.so hello.o -lcurses
|
||||
|
||||
For obvious reasons, this library doesn't interact well
|
||||
with MzScheme's read-eval-print loop. The example file
|
||||
curses-demo.ss demos this extension.
|
||||
*/
|
||||
|
||||
#include "escheme.h"
|
||||
#include <curses.h>
|
||||
|
||||
/**************************************************/
|
||||
|
||||
static Scheme_Object *sch_clear(int argc, Scheme_Object **argv)
|
||||
{
|
||||
clear();
|
||||
}
|
||||
|
||||
static Scheme_Object *sch_put(int argc, Scheme_Object **argv)
|
||||
{
|
||||
/* Puts a char or string on the screen */
|
||||
if (SCHEME_CHARP(argv[0]))
|
||||
addch(SCHEME_CHAR_VAL(argv[0]));
|
||||
else if (SCHEME_STRINGP(argv[0]))
|
||||
addstr(SCHEME_STR_VAL(argv[0]));
|
||||
else
|
||||
scheme_wrong_type("put", "character or string", 0, argc, argv);
|
||||
|
||||
return scheme_void;
|
||||
}
|
||||
|
||||
static Scheme_Object *sch_get(int argc, Scheme_Object **argv)
|
||||
{
|
||||
/* Gets keyboard input */
|
||||
int c = getch();
|
||||
return scheme_make_character(c);
|
||||
}
|
||||
|
||||
static Scheme_Object *sch_move(int argc, Scheme_Object **argv)
|
||||
{
|
||||
/* Move the output cursor */
|
||||
if (!SCHEME_INTP(argv[0]))
|
||||
scheme_wrong_type("move", "exact integer", 0, argc, argv);
|
||||
if (!SCHEME_INTP(argv[1]))
|
||||
scheme_wrong_type("move", "exact integer", 1, argc, argv);
|
||||
|
||||
move(SCHEME_INT_VAL(argv[0]), SCHEME_INT_VAL(argv[0]));
|
||||
|
||||
return scheme_void;
|
||||
}
|
||||
|
||||
static Scheme_Object *sch_get_size(int argc, Scheme_Object **argv)
|
||||
{
|
||||
/* Returns two values */
|
||||
int w, h;
|
||||
Scheme_Object *a[2];
|
||||
|
||||
w = getmaxx(stdscr);
|
||||
h = getmaxy(stdscr);
|
||||
|
||||
a[0] = scheme_make_integer(w);
|
||||
a[1] = scheme_make_integer(h);
|
||||
return scheme_values(1, a);
|
||||
}
|
||||
|
||||
static Scheme_Object *sch_refresh(int argc, Scheme_Object **argv)
|
||||
{
|
||||
refresh();
|
||||
return scheme_void;
|
||||
}
|
||||
|
||||
/**************************************************/
|
||||
|
||||
Scheme_Object *scheme_reload(Scheme_Env *env)
|
||||
{
|
||||
scheme_add_global("clear",
|
||||
scheme_make_prim_w_arity(sch_clear,
|
||||
"clear",
|
||||
0, 0),
|
||||
env);
|
||||
scheme_add_global("put",
|
||||
scheme_make_prim_w_arity(sch_put,
|
||||
"put",
|
||||
1, 1),
|
||||
env);
|
||||
scheme_add_global("get",
|
||||
scheme_make_prim_w_arity(sch_get,
|
||||
"get",
|
||||
0, 0),
|
||||
env);
|
||||
scheme_add_global("move",
|
||||
scheme_make_prim_w_arity(sch_move,
|
||||
"move",
|
||||
2, 2),
|
||||
env);
|
||||
scheme_add_global("get-size",
|
||||
scheme_make_prim_w_arity(sch_get_size,
|
||||
"get-size",
|
||||
0, 0),
|
||||
env);
|
||||
|
||||
scheme_add_global("refresh",
|
||||
scheme_make_prim_w_arity(sch_refresh,
|
||||
"refresh",
|
||||
0, 0),
|
||||
env);
|
||||
|
||||
return scheme_void;
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_initialize(Scheme_Env *env)
|
||||
{
|
||||
/* The first time we're loaded, initialize the screen: */
|
||||
initscr();
|
||||
cbreak();
|
||||
noecho();
|
||||
atexit(endwin);
|
||||
|
||||
/* Then do the usual stuff: */
|
||||
return scheme_reload(env);
|
||||
}
|
||||
|
|
@ -1,59 +0,0 @@
|
|||
/*
|
||||
Extension that defines fmod, modulo on floating-point numbers.
|
||||
The extension is equivalent to Scheme source of them form:
|
||||
(define (fmod a b) ...)
|
||||
*/
|
||||
|
||||
#include "escheme.h"
|
||||
#include <math.h>
|
||||
|
||||
/**************************************************/
|
||||
|
||||
/* Every C implementation of a Scheme function takes argc and an array
|
||||
of Scheme_Object* values for argv, and returns a Scheme_Object*: */
|
||||
static Scheme_Object *sch_fmod(int argc, Scheme_Object **argv)
|
||||
{
|
||||
/* Because we'll use scheme_make_prim_w_arity, MzScheme will
|
||||
have already checked that we're getting the right number of
|
||||
arguments. */
|
||||
Scheme_Object *a = argv[0], *b = argv[1];
|
||||
double v;
|
||||
|
||||
/* Make sure we got real numbers, and complain if not: */
|
||||
if (!SCHEME_REALP(a))
|
||||
scheme_wrong_type("fmod", "real number", 0, argc, argv);
|
||||
/* 1st arg wrong ----^ */
|
||||
if (!SCHEME_REALP(b))
|
||||
scheme_wrong_type("fmod", "real number", 1, argc, argv);
|
||||
/* 2nd arg wrong ----^ */
|
||||
|
||||
/* Convert the Scheme numbers to double-precision floating point
|
||||
numbers, and compute fmod: */
|
||||
v = fmod(scheme_real_to_double(a),
|
||||
scheme_real_to_double(b));
|
||||
|
||||
/* Return the result, packaging it as a Scheme value: */
|
||||
return scheme_make_double(v);
|
||||
}
|
||||
|
||||
/**************************************************/
|
||||
|
||||
Scheme_Object *scheme_reload(Scheme_Env *env)
|
||||
{
|
||||
/* Package the C implementation of fmod into a Scheme procedure
|
||||
value: */
|
||||
Scheme_Object *proc;
|
||||
proc = scheme_make_prim_w_arity(sch_fmod, "fmod", 2, 2);
|
||||
/* Requires at least two args ------^ ^ */
|
||||
/* Accepts no more than two args ---| */
|
||||
|
||||
/* Define `fmod' as a global :*/
|
||||
scheme_add_global("fmod", proc, env);
|
||||
|
||||
return scheme_void;
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_initialize(Scheme_Env *env)
|
||||
{
|
||||
return scheme_reload(env);
|
||||
}
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
/*
|
||||
MzScheme extension example that returns the string "Hello, world!"
|
||||
when loaded.
|
||||
|
||||
Compile with:
|
||||
mzc --cc hello.c
|
||||
mzc --ld hello.so hello.o
|
||||
And load with
|
||||
(load-extension "hello.so")
|
||||
*/
|
||||
|
||||
#include "escheme.h"
|
||||
|
||||
Scheme_Object *scheme_reload(Scheme_Env *env)
|
||||
{
|
||||
/* When the extension is loaded, return a Scheme string: */
|
||||
return scheme_make_string("Hello, world!");
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_initialize(Scheme_Env *env)
|
||||
{
|
||||
/* First load is same as every load: */
|
||||
return scheme_reload(env);
|
||||
}
|
||||
|
|
@ -1,27 +0,0 @@
|
|||
/* Like hello.c, but prints to the current output port and returns
|
||||
(void). */
|
||||
|
||||
#include "escheme.h"
|
||||
|
||||
Scheme_Object *scheme_reload(Scheme_Env *env)
|
||||
{
|
||||
/* Make the string: */
|
||||
Scheme_Object *hw = scheme_make_string("Hello, World!\n");
|
||||
|
||||
/* Display it: */
|
||||
scheme_display(hw, scheme_get_param(scheme_config, MZCONFIG_OUTPUT_PORT));
|
||||
|
||||
/* Why not just
|
||||
printf("Hello, World!\n");
|
||||
? That would write to stdout, which may or may not be the same as
|
||||
the current output port. But sometimes printf() is what you
|
||||
want. */
|
||||
|
||||
return scheme_void;
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_initialize(Scheme_Env *env)
|
||||
{
|
||||
/* First load is same as every load: */
|
||||
return scheme_reload(env);
|
||||
}
|
||||
|
|
@ -1,59 +0,0 @@
|
|||
/*
|
||||
Defines make-adder:
|
||||
(define (make-adder n)
|
||||
(lambda (m) (+ m n)))
|
||||
which illustrates closure-creation, looking up Scheme
|
||||
definitions, and calling Scheme procedures from C.
|
||||
*/
|
||||
|
||||
#include "escheme.h"
|
||||
|
||||
/* The inner lambda, which must close over `n'. A closure function is
|
||||
like a regular Scheme-procedure function, except that it takes an
|
||||
extra argument containing the closure data. The closre data can be
|
||||
any format that we want. */
|
||||
static Scheme_Object *sch_inner(void *closure_data, int argc, Scheme_Object **argv)
|
||||
{
|
||||
/* We only close over one value, so our closure data reprsentation
|
||||
is just thaht value: */
|
||||
Scheme_Object *n = (Scheme_Object *)closure_data;
|
||||
Scheme_Object *plus;
|
||||
Scheme_Object *a[2];
|
||||
|
||||
plus = scheme_lookup_global(scheme_intern_symbol("+"),
|
||||
scheme_get_env(scheme_config));
|
||||
|
||||
/* return the result of summing m and n: */
|
||||
a[0] = n;
|
||||
a[1] = argv[0]; /* m */
|
||||
return _scheme_apply(plus, 2, a);
|
||||
|
||||
/* Actually, that's not quite right. In the Scheme code, (+ m n) is
|
||||
a tail call. The following would be better:
|
||||
return _scheme_tail_apply(plus, 2, a); */
|
||||
}
|
||||
|
||||
static Scheme_Object *sch_make_adder(int argc, Scheme_Object **argv)
|
||||
{
|
||||
return scheme_make_closed_prim_w_arity(sch_inner,
|
||||
argv[0],
|
||||
"adder",
|
||||
1, 1);
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_reload(Scheme_Env *env)
|
||||
{
|
||||
scheme_add_global("make-adder",
|
||||
scheme_make_prim_w_arity(sch_make_adder,
|
||||
"make-adder",
|
||||
1, 1),
|
||||
env);
|
||||
|
||||
return scheme_void;
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_initialize(Scheme_Env *env)
|
||||
{
|
||||
/* First load is same as every load: */
|
||||
return scheme_reload(env);
|
||||
}
|
||||
|
|
@ -1,44 +0,0 @@
|
|||
/*
|
||||
MzScheme
|
||||
Copyright (c) 1995 Matthew Flatt
|
||||
All rights reserved.
|
||||
|
||||
Please see the full copyright in the documentation.
|
||||
|
||||
libscheme
|
||||
Copyright (c) 1994 Brent Benson
|
||||
All rights reserved.
|
||||
*/
|
||||
|
||||
/* This file should be included by MzScheme dynamically-loaded
|
||||
extenstion files */
|
||||
|
||||
#ifndef E_SCHEME_H
|
||||
#define E_SCHEME_H
|
||||
|
||||
#define SCHEME_DIRECT_EMBEDDED 0
|
||||
|
||||
#include "scheme.h"
|
||||
|
||||
#ifdef CODEFRAGMENT_DYNAMIC_LOAD
|
||||
#pragma export on
|
||||
#endif
|
||||
|
||||
#ifdef __cplusplus
|
||||
extern "C"
|
||||
{
|
||||
#endif
|
||||
|
||||
extern Scheme_Object *scheme_initialize(Scheme_Env *global_env);
|
||||
extern Scheme_Object *scheme_reload(Scheme_Env *global_env);
|
||||
|
||||
#ifdef __cplusplus
|
||||
};
|
||||
#endif
|
||||
|
||||
#ifdef CODEFRAGMENT_DYNAMIC_LOAD
|
||||
#pragma export off
|
||||
#endif
|
||||
|
||||
#endif /* ! E_SCHEME_H */
|
||||
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
#! ..
|
||||
scheme_initialize_internal
|
||||
scheme_initialize
|
||||
scheme_reload
|
||||
|
|
@ -1,311 +0,0 @@
|
|||
#!..
|
||||
scheme_init_jmpup_buf
|
||||
scheme_setjmpup_relative
|
||||
scheme_longjmpup
|
||||
scheme_reset_jmpup_buf
|
||||
scheme_clear_escape
|
||||
scheme_make_config
|
||||
scheme_branch_config
|
||||
scheme_new_param
|
||||
scheme_param_config
|
||||
scheme_register_parameter
|
||||
scheme_get_env
|
||||
scheme_current_process
|
||||
scheme_fuel_counter
|
||||
scheme_thread
|
||||
scheme_thread_w_manager
|
||||
scheme_kill_thread
|
||||
scheme_break_thread
|
||||
scheme_process_block
|
||||
scheme_swap_process
|
||||
scheme_weak_suspend_thread
|
||||
scheme_weak_resume_thread
|
||||
scheme_block_until
|
||||
scheme_in_main_thread
|
||||
scheme_tls_allocate
|
||||
scheme_tls_set
|
||||
scheme_tls_get
|
||||
scheme_make_manager
|
||||
scheme_add_managed
|
||||
scheme_remove_managed
|
||||
scheme_close_managed
|
||||
scheme_signal_error
|
||||
scheme_raise_exn
|
||||
scheme_warning
|
||||
scheme_wrong_count
|
||||
scheme_case_lambda_wrong_count
|
||||
scheme_wrong_type
|
||||
scheme_arg_mismatch
|
||||
scheme_wrong_return_arity
|
||||
scheme_unbound_global
|
||||
scheme_dynamic_wind
|
||||
scheme_make_type
|
||||
scheme_install_type_reader
|
||||
scheme_install_type_writer
|
||||
scheme_eof
|
||||
scheme_null
|
||||
scheme_true
|
||||
scheme_false
|
||||
scheme_void
|
||||
scheme_undefined
|
||||
scheme_tail_call_waiting
|
||||
scheme_multiple_values
|
||||
scheme_eval
|
||||
scheme_eval_multi
|
||||
scheme_eval_compiled
|
||||
scheme_eval_compiled_multi
|
||||
_scheme_eval_compiled
|
||||
_scheme_eval_compiled_multi
|
||||
scheme_apply
|
||||
scheme_apply_multi
|
||||
scheme_apply_eb
|
||||
scheme_apply_multi_eb
|
||||
scheme_apply_to_list
|
||||
scheme_eval_string
|
||||
scheme_eval_string_multi
|
||||
scheme_eval_string_all
|
||||
_scheme_apply_known_closed_prim
|
||||
_scheme_apply_known_closed_prim_multi
|
||||
_scheme_apply_closed_prim
|
||||
_scheme_apply_closed_prim_multi
|
||||
scheme_values
|
||||
scheme_check_one_value
|
||||
scheme_tail_apply
|
||||
scheme_tail_apply_no_copy
|
||||
scheme_tail_apply_to_list
|
||||
scheme_tail_eval_expr
|
||||
scheme_set_tail_buffer_size
|
||||
scheme_force_value
|
||||
scheme_set_cont_mark
|
||||
scheme_push_continuation_frame
|
||||
scheme_pop_continuation_frame
|
||||
scheme_temp_dec_mark_depth
|
||||
scheme_temp_inc_mark_depth
|
||||
scheme_current_continuation_marks
|
||||
scheme_do_eval
|
||||
GC_malloc
|
||||
GC_malloc_atomic
|
||||
GC_malloc_stubborn
|
||||
GC_malloc_uncollectable
|
||||
scheme_malloc_eternal
|
||||
scheme_end_stubborn_change
|
||||
scheme_calloc
|
||||
scheme_strdup
|
||||
scheme_strdup_eternal
|
||||
scheme_malloc_fail_ok
|
||||
scheme_weak_reference
|
||||
scheme_weak_reference_indirect
|
||||
scheme_unweak_reference
|
||||
scheme_add_finalizer
|
||||
scheme_add_finalizer_once
|
||||
scheme_add_scheme_finalizer
|
||||
scheme_add_scheme_finalizer_once
|
||||
scheme_register_finalizer
|
||||
scheme_remove_all_finalization
|
||||
scheme_dont_gc_ptr
|
||||
scheme_gc_ptr_ok
|
||||
scheme_collect_garbage
|
||||
scheme_hash_table
|
||||
scheme_add_to_table
|
||||
scheme_change_in_table
|
||||
scheme_lookup_in_table
|
||||
scheme_bucket_from_table
|
||||
scheme_make_prim
|
||||
scheme_make_noneternal_prim
|
||||
scheme_make_closed_prim
|
||||
scheme_make_prim_w_arity
|
||||
scheme_make_folding_prim
|
||||
scheme_make_noneternal_prim_w_arity
|
||||
scheme_make_closed_prim_w_arity
|
||||
scheme_make_folding_closed_prim
|
||||
scheme_make_closure
|
||||
scheme_make_pair
|
||||
scheme_make_string
|
||||
scheme_make_sized_string
|
||||
scheme_make_sized_offset_string
|
||||
scheme_make_immutable_sized_string
|
||||
scheme_make_string_without_copying
|
||||
scheme_alloc_string
|
||||
scheme_append_string
|
||||
scheme_make_vector
|
||||
scheme_make_integer_value
|
||||
scheme_make_integer_value_from_unsigned
|
||||
scheme_make_double
|
||||
scheme_make_char
|
||||
scheme_make_promise
|
||||
scheme_make_promise_from_thunk
|
||||
scheme_make_sema
|
||||
scheme_post_sema
|
||||
scheme_wait_sema
|
||||
scheme_char_constants
|
||||
scheme_get_int_val
|
||||
scheme_get_unsigned_int_val
|
||||
scheme_real_to_double
|
||||
scheme_get_proc_name
|
||||
scheme_make_bignum
|
||||
scheme_make_bignum_from_unsigned
|
||||
scheme_bignum_to_double
|
||||
scheme_bignum_from_double
|
||||
scheme_bignum_to_string
|
||||
scheme_read_bignum
|
||||
scheme_bignum_normalize
|
||||
scheme_double_to_int
|
||||
scheme_make_rational
|
||||
scheme_rational_to_double
|
||||
scheme_rational_from_double
|
||||
scheme_rational_normalize
|
||||
scheme_rational_numerator
|
||||
scheme_rational_denominator
|
||||
scheme_make_complex
|
||||
scheme_complex_normalize
|
||||
scheme_complex_real_part
|
||||
scheme_complex_imaginary_part
|
||||
scheme_is_exact
|
||||
scheme_is_inexact
|
||||
scheme_expand
|
||||
scheme_compile
|
||||
scheme_make_promise_value
|
||||
scheme_read
|
||||
scheme_write
|
||||
scheme_display
|
||||
scheme_write_w_max
|
||||
scheme_display_w_max
|
||||
scheme_write_string
|
||||
scheme_write_offset_string
|
||||
scheme_write_to_string
|
||||
scheme_display_to_string
|
||||
scheme_write_to_string_w_max
|
||||
scheme_display_to_string_w_max
|
||||
scheme_debug_print
|
||||
scheme_flush_output
|
||||
scheme_format
|
||||
scheme_printf
|
||||
scheme_getc
|
||||
scheme_peekc
|
||||
scheme_ungetc
|
||||
scheme_char_ready
|
||||
scheme_peekc_is_ungetc
|
||||
scheme_need_wakeup
|
||||
scheme_get_chars
|
||||
scheme_tell
|
||||
scheme_output_tell
|
||||
scheme_tell_line
|
||||
scheme_count_lines
|
||||
scheme_close_input_port
|
||||
scheme_close_output_port
|
||||
scheme_are_all_chars_ready
|
||||
scheme_make_port_type
|
||||
scheme_make_input_port
|
||||
scheme_make_output_port
|
||||
scheme_make_file_input_port
|
||||
scheme_make_named_file_input_port
|
||||
scheme_make_file_output_port
|
||||
scheme_make_string_input_port
|
||||
scheme_make_sized_string_input_port
|
||||
scheme_make_string_output_port
|
||||
scheme_get_string_output
|
||||
scheme_get_sized_string_output
|
||||
scheme_pipe
|
||||
scheme_file_exists
|
||||
scheme_directory_exists
|
||||
scheme_expand_filename
|
||||
scheme_os_getcwd
|
||||
scheme_os_setcwd
|
||||
scheme_getdrive
|
||||
scheme_split_pathname
|
||||
scheme_build_pathname
|
||||
scheme_alloc_fdset_array
|
||||
scheme_init_fdset_array
|
||||
scheme_get_fdset
|
||||
scheme_fdzero
|
||||
scheme_fdset
|
||||
scheme_fdclr
|
||||
scheme_fdisset
|
||||
scheme_add_fd_handle
|
||||
scheme_add_fd_eventmask
|
||||
scheme_return_eof_for_error
|
||||
scheme_make_namespace
|
||||
scheme_add_namespace_option
|
||||
scheme_add_global
|
||||
scheme_add_global_constant
|
||||
scheme_add_global_keyword
|
||||
scheme_remove_global
|
||||
scheme_remove_global_constant
|
||||
scheme_add_global_symbol
|
||||
scheme_remove_global_symbol
|
||||
scheme_add_global_constant_symbol
|
||||
scheme_set_keyword
|
||||
scheme_make_envunbox
|
||||
scheme_lookup_global
|
||||
scheme_global_bucket
|
||||
scheme_set_global_bucket
|
||||
scheme_intern_symbol
|
||||
scheme_intern_exact_symbol
|
||||
scheme_make_symbol
|
||||
scheme_make_exact_symbol
|
||||
scheme_symbol_name
|
||||
scheme_symbol_name_and_size
|
||||
scheme_symbol_val
|
||||
scheme_make_struct_values
|
||||
scheme_make_struct_names
|
||||
scheme_make_struct_type
|
||||
scheme_make_struct_instance
|
||||
scheme_is_struct_instance
|
||||
scheme_struct_ref
|
||||
scheme_struct_set
|
||||
scheme_is_subclass
|
||||
scheme_is_implementation
|
||||
scheme_is_interface_extension
|
||||
scheme_is_a
|
||||
scheme_get_class_name
|
||||
scheme_get_interface_name
|
||||
scheme_make_object
|
||||
scheme_make_uninited_object
|
||||
scheme_find_ivar
|
||||
scheme_make_class
|
||||
scheme_add_method
|
||||
scheme_add_method_w_arity
|
||||
scheme_made_class
|
||||
scheme_class_to_interface
|
||||
scheme_make_class_assembly
|
||||
scheme_create_class
|
||||
scheme_make_interface_assembly
|
||||
scheme_create_interface
|
||||
scheme_apply_generic_data
|
||||
scheme_get_generic_data
|
||||
scheme_invoke_unit
|
||||
scheme_assemble_compound_unit
|
||||
scheme_make_compound_unit
|
||||
scheme_get_unit_name
|
||||
scheme_eq
|
||||
scheme_eqv
|
||||
scheme_equal
|
||||
scheme_build_list
|
||||
scheme_list_length
|
||||
scheme_proper_list_length
|
||||
scheme_alloc_list
|
||||
scheme_map_1
|
||||
scheme_car
|
||||
scheme_cdr
|
||||
scheme_cadr
|
||||
scheme_caddr
|
||||
scheme_vector_to_list
|
||||
scheme_list_to_vector
|
||||
scheme_append
|
||||
scheme_box
|
||||
scheme_unbox
|
||||
scheme_set_box
|
||||
scheme_make_weak_box
|
||||
scheme_load
|
||||
scheme_load_extension
|
||||
scheme_register_extension_global
|
||||
scheme_get_milliseconds
|
||||
scheme_get_process_milliseconds
|
||||
scheme_rep
|
||||
scheme_banner
|
||||
scheme_version
|
||||
scheme_check_proc_arity
|
||||
scheme_make_provided_string
|
||||
scheme_make_args_string
|
||||
scheme_no_dumps
|
||||
scheme_system_library_subpath
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,677 +0,0 @@
|
|||
/*
|
||||
MzScheme
|
||||
Copyright (c) 1995-2000 Matthew Flatt
|
||||
All rights reserved.
|
||||
|
||||
Please see the full copyright in the documentation.
|
||||
|
||||
Originally based on:
|
||||
libscheme
|
||||
Copyright (c) 1994 Brent Benson
|
||||
All rights reserved.
|
||||
*/
|
||||
|
||||
/* MzScheme function prototypes */
|
||||
/* Macros generally shouldn't go in this file; it is used both to
|
||||
prototype functions, and as a parsing source for
|
||||
declaring scheme_extension_table */
|
||||
|
||||
/* The scheme_extension_table "parser" is picky; don't leave a space
|
||||
between a function name and it's opening parameter parenthesis. */
|
||||
|
||||
/* After this START tag, all comments should start & end on same line */
|
||||
|
||||
/* START */
|
||||
|
||||
/*========================================================================*/
|
||||
/* setjmpup (continuations) */
|
||||
/*========================================================================*/
|
||||
|
||||
void scheme_init_jmpup_buf(Scheme_Jumpup_Buf *b);
|
||||
int scheme_setjmpup_relative(Scheme_Jumpup_Buf *b, void *base,
|
||||
void *start, Scheme_Jumpup_Buf *cont);
|
||||
void scheme_longjmpup(Scheme_Jumpup_Buf *b);
|
||||
void scheme_reset_jmpup_buf(Scheme_Jumpup_Buf *b);
|
||||
|
||||
#ifdef USE_MZ_SETJMP
|
||||
int scheme_setjmp(mz_jmp_buf b);
|
||||
void scheme_longjmp(mz_jmp_buf b, int v);
|
||||
#endif
|
||||
|
||||
void scheme_clear_escape(void);
|
||||
|
||||
/*========================================================================*/
|
||||
/* parameters */
|
||||
/*========================================================================*/
|
||||
|
||||
Scheme_Object *scheme_make_config(Scheme_Config *base);
|
||||
Scheme_Object *scheme_branch_config(void);
|
||||
int scheme_new_param(void);
|
||||
|
||||
Scheme_Object *scheme_param_config(char *name, Scheme_Object *pos,
|
||||
int argc, Scheme_Object **argv,
|
||||
int arity,
|
||||
Scheme_Prim *check, char *expected,
|
||||
int isbool);
|
||||
Scheme_Object *scheme_register_parameter(Scheme_Prim *function, char *name, int which);
|
||||
Scheme_Env *scheme_get_env(Scheme_Config *config);
|
||||
|
||||
/*========================================================================*/
|
||||
/* threads */
|
||||
/*========================================================================*/
|
||||
|
||||
#ifdef MZ_REAL_THREADS
|
||||
Scheme_Process *scheme_get_current_process();
|
||||
#else
|
||||
#ifndef LINK_EXTENSIONS_BY_TABLE
|
||||
extern Scheme_Process *scheme_current_process;
|
||||
extern int scheme_fuel_counter;
|
||||
#else
|
||||
extern Scheme_Process **scheme_current_process_ptr;
|
||||
extern int *scheme_fuel_counter_ptr;
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#ifndef NO_SCHEME_THREADS
|
||||
Scheme_Object *scheme_thread(Scheme_Object *thunk, Scheme_Config *config);
|
||||
Scheme_Object *scheme_thread_w_manager(Scheme_Object *thunk, Scheme_Config *config,
|
||||
Scheme_Manager *mgr);
|
||||
void scheme_kill_thread(Scheme_Process *p);
|
||||
#endif
|
||||
void scheme_break_thread(Scheme_Process *p);
|
||||
|
||||
#ifndef MZ_REAL_THREADS
|
||||
void scheme_process_block(float sleep_time);
|
||||
void scheme_swap_process(Scheme_Process *process);
|
||||
#else
|
||||
void scheme_process_block_w_process(float sleep_time, Scheme_Process *p);
|
||||
#endif
|
||||
|
||||
void scheme_weak_suspend_thread(Scheme_Process *p);
|
||||
void scheme_weak_resume_thread(Scheme_Process *p);
|
||||
|
||||
int scheme_block_until(int (*f)(Scheme_Object *), void (*fdfd)(Scheme_Object *, void *), void *, float);
|
||||
|
||||
int scheme_in_main_thread(void);
|
||||
|
||||
int scheme_tls_allocate();
|
||||
void scheme_tls_set(int pos, void *v);
|
||||
void *scheme_tls_get(int pos);
|
||||
|
||||
Scheme_Manager *scheme_make_manager(Scheme_Manager *);
|
||||
Scheme_Manager_Reference *scheme_add_managed(Scheme_Manager *m, Scheme_Object *o,
|
||||
Scheme_Close_Manager_Client *f, void *data,
|
||||
int strong);
|
||||
void scheme_remove_managed(Scheme_Manager_Reference *m, Scheme_Object *o);
|
||||
void scheme_close_managed(Scheme_Manager *m);
|
||||
|
||||
/*========================================================================*/
|
||||
/* error handling */
|
||||
/*========================================================================*/
|
||||
|
||||
void scheme_signal_error(char *msg, ...);
|
||||
void scheme_raise_exn(int exnid, ...);
|
||||
void scheme_warning(char *msg, ...);
|
||||
|
||||
void scheme_wrong_count(const char *name, int minc, int maxc, int argc,
|
||||
Scheme_Object **argv);
|
||||
void scheme_case_lambda_wrong_count(const char *name, int argc,
|
||||
Scheme_Object **argv, int count, ...);
|
||||
void scheme_wrong_type(const char *name, const char *expected,
|
||||
int which, int argc,
|
||||
Scheme_Object **argv);
|
||||
void scheme_arg_mismatch(const char *name, const char *msg, Scheme_Object *o);
|
||||
void scheme_wrong_return_arity(const char *where,
|
||||
int expected, int got,
|
||||
Scheme_Object **argv,
|
||||
const char *context_detail, ...);
|
||||
void scheme_unbound_global(Scheme_Object *name) ;
|
||||
|
||||
Scheme_Object *scheme_dynamic_wind(void (*pre)(void *),
|
||||
Scheme_Object *(*act)(void *),
|
||||
void (*post)(void *),
|
||||
Scheme_Object *(*jmp_handler)(void *),
|
||||
void *data);
|
||||
|
||||
/*========================================================================*/
|
||||
/* types */
|
||||
/*========================================================================*/
|
||||
|
||||
Scheme_Type scheme_make_type(const char *name);
|
||||
|
||||
/* Type readers & writers for compiled code data */
|
||||
void scheme_install_type_reader(Scheme_Type type, Scheme_Type_Reader f);
|
||||
void scheme_install_type_writer(Scheme_Type type, Scheme_Type_Writer f);
|
||||
|
||||
/*========================================================================*/
|
||||
/* constants */
|
||||
/*========================================================================*/
|
||||
|
||||
extern Scheme_Object scheme_eof[1];
|
||||
extern Scheme_Object scheme_null[1];
|
||||
extern Scheme_Object scheme_true[1];
|
||||
extern Scheme_Object scheme_false[1];
|
||||
extern Scheme_Object scheme_void[1];
|
||||
extern Scheme_Object scheme_undefined[1];
|
||||
extern Scheme_Object *scheme_tail_call_waiting;
|
||||
extern Scheme_Object *scheme_multiple_values;
|
||||
|
||||
/*========================================================================*/
|
||||
/* evaluation */
|
||||
/*========================================================================*/
|
||||
|
||||
Scheme_Object *scheme_eval(Scheme_Object *obj, Scheme_Env *env);
|
||||
Scheme_Object *scheme_eval_multi(Scheme_Object *obj, Scheme_Env *env);
|
||||
Scheme_Object *scheme_eval_compiled(Scheme_Object *obj);
|
||||
Scheme_Object *scheme_eval_compiled_multi(Scheme_Object *obj);
|
||||
Scheme_Object *_scheme_eval_compiled(Scheme_Object *obj);
|
||||
Scheme_Object *_scheme_eval_compiled_multi(Scheme_Object *obj);
|
||||
#ifndef MZ_REAL_THREADS
|
||||
Scheme_Object *scheme_apply(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
|
||||
Scheme_Object *scheme_apply_multi(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
|
||||
Scheme_Object *scheme_apply_eb(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
|
||||
Scheme_Object *scheme_apply_multi_eb(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
|
||||
#else
|
||||
Scheme_Object *scheme_apply_wp(Scheme_Object *rator, int num_rands, Scheme_Object **rands,
|
||||
Scheme_Process *p);
|
||||
Scheme_Object *scheme_apply_multi_wp(Scheme_Object *rator, int num_rands, Scheme_Object **rands,
|
||||
Scheme_Process *p);
|
||||
Scheme_Object *scheme_apply_eb_wp(Scheme_Object *rator, int num_rands, Scheme_Object **rands,
|
||||
Scheme_Process *p);
|
||||
Scheme_Object *scheme_apply_multi_eb_wp(Scheme_Object *rator, int num_rands, Scheme_Object **rands,
|
||||
Scheme_Process *p);
|
||||
#endif
|
||||
Scheme_Object *scheme_apply_to_list(Scheme_Object *rator, Scheme_Object *argss);
|
||||
Scheme_Object *scheme_eval_string(const char *str, Scheme_Env *env);
|
||||
Scheme_Object *scheme_eval_string_multi(const char *str, Scheme_Env *env);
|
||||
Scheme_Object *scheme_eval_string_all(const char *str, Scheme_Env *env, int all);
|
||||
|
||||
Scheme_Object *_scheme_apply_known_closed_prim(Scheme_Object *rator, int argc,
|
||||
Scheme_Object **argv);
|
||||
Scheme_Object *_scheme_apply_known_closed_prim_multi(Scheme_Object *rator, int argc,
|
||||
Scheme_Object **argv);
|
||||
Scheme_Object *_scheme_apply_closed_prim(Scheme_Object *rator, int argc,
|
||||
Scheme_Object **argv);
|
||||
Scheme_Object *_scheme_apply_closed_prim_multi(Scheme_Object *rator, int argc,
|
||||
Scheme_Object **argv);
|
||||
|
||||
Scheme_Object *scheme_values(int c, Scheme_Object **v);
|
||||
|
||||
Scheme_Object *scheme_check_one_value(Scheme_Object *v);
|
||||
|
||||
/* Tail calls - only use these when you're writing new functions/syntax */
|
||||
Scheme_Object *scheme_tail_apply(Scheme_Object *f, int n, Scheme_Object **arg);
|
||||
Scheme_Object *scheme_tail_apply_no_copy(Scheme_Object *f, int n, Scheme_Object **arg);
|
||||
Scheme_Object *scheme_tail_apply_to_list(Scheme_Object *f, Scheme_Object *l);
|
||||
|
||||
Scheme_Object *scheme_tail_eval_expr(Scheme_Object *obj);
|
||||
|
||||
void scheme_set_tail_buffer_size(int s);
|
||||
Scheme_Object *scheme_force_value(Scheme_Object *);
|
||||
|
||||
void scheme_set_cont_mark(Scheme_Object *key, Scheme_Object *val);
|
||||
void scheme_push_continuation_frame(Scheme_Cont_Frame_Data *);
|
||||
void scheme_pop_continuation_frame(Scheme_Cont_Frame_Data *);
|
||||
void scheme_temp_dec_mark_depth();
|
||||
void scheme_temp_inc_mark_depth();
|
||||
|
||||
Scheme_Object *scheme_current_continuation_marks(void);
|
||||
|
||||
/* Internal */
|
||||
#ifndef MZ_REAL_THREADS
|
||||
Scheme_Object *scheme_do_eval(Scheme_Object *obj, int _num_rands, Scheme_Object **rands, int val);
|
||||
#else
|
||||
Scheme_Object *scheme_do_eval_w_process(Scheme_Object *obj, int _num_rands, Scheme_Object **rands, int val, Scheme_Process *p);
|
||||
#endif
|
||||
|
||||
/*========================================================================*/
|
||||
/* memory management */
|
||||
/*========================================================================*/
|
||||
|
||||
/* The core allocator functions depend on the GC. Macros in scheme.h */
|
||||
/* map to the apporpriate core allocation function. */
|
||||
|
||||
#ifndef SCHEME_NO_GC
|
||||
# ifndef SCHEME_NO_GC_PROTO
|
||||
void *GC_malloc(size_t size_in_bytes);
|
||||
void *GC_malloc_atomic(size_t size_in_bytes);
|
||||
# ifdef MZ_PRECISE_GC
|
||||
void *GC_malloc_one_tagged(size_t size_in_bytes);
|
||||
void *GC_malloc_atomic_uncollectable(size_t size_in_bytes);
|
||||
void *GC_malloc_array_tagged(size_t size_in_bytes);
|
||||
# else
|
||||
void *GC_malloc_stubborn(size_t size_in_bytes);
|
||||
void *GC_malloc_uncollectable(size_t size_in_bytes);
|
||||
# endif
|
||||
# endif
|
||||
#endif
|
||||
|
||||
void *scheme_malloc_eternal(size_t n);
|
||||
void scheme_end_stubborn_change(void *p);
|
||||
|
||||
void *scheme_calloc(size_t num, size_t size);
|
||||
|
||||
char *scheme_strdup(const char *str);
|
||||
char *scheme_strdup_eternal(const char *str);
|
||||
|
||||
void *scheme_malloc_fail_ok(void *(*f)(size_t), size_t);
|
||||
|
||||
void scheme_weak_reference(void **p);
|
||||
void scheme_weak_reference_indirect(void **p, void *v);
|
||||
void scheme_unweak_reference(void **p);
|
||||
void scheme_add_finalizer(void *p, void (*f)(void *p, void *data), void *data);
|
||||
void scheme_add_finalizer_once(void *p, void (*f)(void *p, void *data), void *data);
|
||||
void scheme_add_scheme_finalizer(void *p, void (*f)(void *p, void *data), void *data);
|
||||
void scheme_add_scheme_finalizer_once(void *p, void (*f)(void *p, void *data), void *data);
|
||||
void scheme_register_finalizer(void *p,
|
||||
void (*f)(void *p, void *data), void *data,
|
||||
void (**oldf)(void *p, void *data),
|
||||
void **olddata);
|
||||
void scheme_remove_all_finalization(void *p);
|
||||
|
||||
void scheme_dont_gc_ptr(void *p);
|
||||
void scheme_gc_ptr_ok(void *p);
|
||||
|
||||
void scheme_collect_garbage(void);
|
||||
|
||||
/*========================================================================*/
|
||||
/* hash tables */
|
||||
/*========================================================================*/
|
||||
|
||||
Scheme_Hash_Table *scheme_hash_table(int size, int type,
|
||||
int w_const, int forever);
|
||||
void scheme_add_to_table(Scheme_Hash_Table *table, const char *key, void *val, int);
|
||||
void scheme_change_in_table(Scheme_Hash_Table *table, const char *key, void *new_val);
|
||||
void *scheme_lookup_in_table(Scheme_Hash_Table *table, const char *key);
|
||||
Scheme_Bucket *scheme_bucket_from_table(Scheme_Hash_Table *table, const char *key);
|
||||
|
||||
/*========================================================================*/
|
||||
/* basic Scheme value constructors */
|
||||
/*========================================================================*/
|
||||
|
||||
Scheme_Object *scheme_make_prim(Scheme_Prim *prim);
|
||||
Scheme_Object *scheme_make_noneternal_prim(Scheme_Prim *prim);
|
||||
Scheme_Object *scheme_make_closed_prim(Scheme_Closed_Prim *prim, void *data);
|
||||
Scheme_Object *scheme_make_prim_w_arity(Scheme_Prim *prim, const char *name,
|
||||
short mina, short maxa);
|
||||
Scheme_Object *scheme_make_folding_prim(Scheme_Prim *prim,
|
||||
const char *name,
|
||||
short mina, short maxa,
|
||||
short functional);
|
||||
Scheme_Object *scheme_make_noneternal_prim_w_arity(Scheme_Prim *prim,
|
||||
const char *name,
|
||||
short mina, short maxa);
|
||||
Scheme_Object *scheme_make_closed_prim_w_arity(Scheme_Closed_Prim *prim,
|
||||
void *data, const char *name,
|
||||
short mina, short maxa);
|
||||
Scheme_Object *scheme_make_folding_closed_prim(Scheme_Closed_Prim *prim,
|
||||
void *data, const char *name,
|
||||
short mina, short maxa,
|
||||
short functional);
|
||||
|
||||
Scheme_Object *scheme_make_closure(Scheme_Env *env, Scheme_Object *code);
|
||||
Scheme_Object *scheme_make_pair(Scheme_Object *car, Scheme_Object *cdr);
|
||||
Scheme_Object *scheme_make_string(const char *chars);
|
||||
Scheme_Object *scheme_make_sized_string(char *chars, long len, int copy);
|
||||
Scheme_Object *scheme_make_sized_offset_string(char *chars, long d, long len, int copy);
|
||||
Scheme_Object *scheme_make_immutable_sized_string(char *chars, long len, int copy);
|
||||
Scheme_Object *scheme_make_string_without_copying(char *chars);
|
||||
Scheme_Object *scheme_alloc_string(int size, char fill);
|
||||
Scheme_Object *scheme_append_string(Scheme_Object *, Scheme_Object *);
|
||||
Scheme_Object *scheme_make_vector(int size, Scheme_Object *fill);
|
||||
Scheme_Object *scheme_make_integer_value(long i);
|
||||
Scheme_Object *scheme_make_integer_value_from_unsigned(unsigned long i);
|
||||
Scheme_Object *scheme_make_double(double d);
|
||||
#ifdef MZ_USE_SINGLE_FLOATS
|
||||
Scheme_Object *scheme_make_float(float f) ;
|
||||
#endif
|
||||
Scheme_Object *scheme_make_char(char ch);
|
||||
Scheme_Object *scheme_make_promise(Scheme_Object *expr, Scheme_Env *env);
|
||||
Scheme_Object *scheme_make_promise_from_thunk(Scheme_Object *expr);
|
||||
#ifndef NO_SCHEME_THREADS
|
||||
Scheme_Object *scheme_make_sema(long v);
|
||||
void scheme_post_sema(Scheme_Object *o);
|
||||
int scheme_wait_sema(Scheme_Object *o, int just_try);
|
||||
#endif
|
||||
extern Scheme_Object **scheme_char_constants;
|
||||
|
||||
int scheme_get_int_val(Scheme_Object *o, long *v);
|
||||
int scheme_get_unsigned_int_val(Scheme_Object *o, unsigned long *v);
|
||||
|
||||
double scheme_real_to_double(Scheme_Object *r);
|
||||
|
||||
const char *scheme_get_proc_name(Scheme_Object *p, int *len, int for_error);
|
||||
|
||||
/*========================================================================*/
|
||||
/* bignums */
|
||||
/*========================================================================*/
|
||||
|
||||
Scheme_Object *scheme_make_bignum(long v);
|
||||
Scheme_Object *scheme_make_bignum_from_unsigned(unsigned long v);
|
||||
double scheme_bignum_to_double(const Scheme_Object *n);
|
||||
Scheme_Object *scheme_bignum_from_double(double d);
|
||||
#ifdef MZ_USE_SINGLE_FLOATS
|
||||
float scheme_bignum_to_float(const Scheme_Object *n);
|
||||
Scheme_Object *scheme_bignum_from_float(float d);
|
||||
#else
|
||||
# define scheme_bignum_to_float scheme_bignum_to_double
|
||||
# define scheme_bignum_from_float scheme_bignum_from_double
|
||||
#endif
|
||||
char *scheme_bignum_to_string(const Scheme_Object *n, int radix);
|
||||
Scheme_Object *scheme_read_bignum(const char *str, int offset, int radix);
|
||||
Scheme_Object *scheme_bignum_normalize(const Scheme_Object *n);
|
||||
|
||||
long scheme_double_to_int(const char *where, double d) ;
|
||||
|
||||
/*========================================================================*/
|
||||
/* rationals */
|
||||
/*========================================================================*/
|
||||
|
||||
Scheme_Object *scheme_make_rational(const Scheme_Object *r, const Scheme_Object *d);
|
||||
double scheme_rational_to_double(const Scheme_Object *n);
|
||||
Scheme_Object *scheme_rational_from_double(double d);
|
||||
#ifdef MZ_USE_SINGLE_FLOATS
|
||||
float scheme_rational_to_float(const Scheme_Object *n);
|
||||
Scheme_Object *scheme_rational_from_float(float d);
|
||||
#else
|
||||
# define scheme_rational_to_float scheme_rational_to_double
|
||||
# define scheme_rational_from_float scheme_rational_from_double
|
||||
#endif
|
||||
Scheme_Object *scheme_rational_normalize(const Scheme_Object *n);
|
||||
Scheme_Object *scheme_rational_numerator(const Scheme_Object *n);
|
||||
Scheme_Object *scheme_rational_denominator(const Scheme_Object *n);
|
||||
|
||||
/*========================================================================*/
|
||||
/* complexes */
|
||||
/*========================================================================*/
|
||||
|
||||
Scheme_Object *scheme_make_complex(const Scheme_Object *r, const Scheme_Object *i);
|
||||
Scheme_Object *scheme_complex_normalize(const Scheme_Object *n);
|
||||
Scheme_Object *scheme_complex_real_part(const Scheme_Object *n);
|
||||
Scheme_Object *scheme_complex_imaginary_part(const Scheme_Object *n);
|
||||
|
||||
/* Exact/inexact: */
|
||||
int scheme_is_exact(Scheme_Object *n);
|
||||
int scheme_is_inexact(Scheme_Object *n);
|
||||
|
||||
/*========================================================================*/
|
||||
/* macros, syntax, and compilation */
|
||||
/*========================================================================*/
|
||||
|
||||
Scheme_Object *scheme_expand(Scheme_Object *form, Scheme_Env *env);
|
||||
|
||||
Scheme_Object *scheme_compile(Scheme_Object *form, Scheme_Env *env, int writeable);
|
||||
Scheme_Object *scheme_make_promise_value(Scheme_Object *compiled_expr);
|
||||
|
||||
/*========================================================================*/
|
||||
/* ports */
|
||||
/*========================================================================*/
|
||||
|
||||
Scheme_Object *scheme_read(Scheme_Object *port);
|
||||
void scheme_write(Scheme_Object *obj, Scheme_Object *port);
|
||||
void scheme_display(Scheme_Object *obj, Scheme_Object *port);
|
||||
void scheme_write_w_max(Scheme_Object *obj, Scheme_Object *port, long maxl);
|
||||
void scheme_display_w_max(Scheme_Object *obj, Scheme_Object *port, long maxl);
|
||||
void scheme_write_string(const char *str, long len, Scheme_Object *port);
|
||||
void scheme_write_offset_string(const char *str, long d, long len, Scheme_Object *port);
|
||||
char *scheme_write_to_string(Scheme_Object *obj, long *len);
|
||||
char *scheme_display_to_string(Scheme_Object *obj, long *len);
|
||||
char *scheme_write_to_string_w_max(Scheme_Object *obj, long *len, long maxl);
|
||||
char *scheme_display_to_string_w_max(Scheme_Object *obj, long *len, long maxl);
|
||||
void scheme_debug_print(Scheme_Object *obj);
|
||||
void scheme_flush_output(Scheme_Object *port);
|
||||
|
||||
char *scheme_format(char *format, int flen, int argc, Scheme_Object **argv, int *rlen);
|
||||
void scheme_printf(char *format, int flen, int argc, Scheme_Object **argv);
|
||||
|
||||
int scheme_getc(Scheme_Object *port);
|
||||
int scheme_peekc(Scheme_Object *port);
|
||||
void scheme_ungetc(int ch, Scheme_Object *port);
|
||||
int scheme_char_ready(Scheme_Object *port);
|
||||
int scheme_peekc_is_ungetc(Scheme_Object *port);
|
||||
void scheme_need_wakeup(Scheme_Object *port, void *fds);
|
||||
long scheme_get_chars(Scheme_Object *port, long size, char *buffer, int offset);
|
||||
long scheme_tell(Scheme_Object *port);
|
||||
long scheme_output_tell(Scheme_Object *port);
|
||||
long scheme_tell_line(Scheme_Object *port);
|
||||
void scheme_count_lines(Scheme_Object *port);
|
||||
void scheme_close_input_port(Scheme_Object *port);
|
||||
void scheme_close_output_port(Scheme_Object *port);
|
||||
int scheme_are_all_chars_ready(Scheme_Object *port);
|
||||
|
||||
Scheme_Object *scheme_make_port_type(const char *name);
|
||||
Scheme_Input_Port *scheme_make_input_port(Scheme_Object *subtype, void *data,
|
||||
int (*getc_fun)(Scheme_Input_Port*),
|
||||
int (*peekc_fun)(Scheme_Input_Port*),
|
||||
int (*char_ready_fun)
|
||||
(Scheme_Input_Port*),
|
||||
void (*close_fun)
|
||||
(Scheme_Input_Port*),
|
||||
void (*need_wakeup_fun)
|
||||
(Scheme_Input_Port*, void *),
|
||||
int must_close);
|
||||
Scheme_Output_Port *scheme_make_output_port(Scheme_Object *subtype,
|
||||
void *data,
|
||||
void (*write_string_fun)
|
||||
(char*, long, long, Scheme_Output_Port*),
|
||||
void (*close_fun)
|
||||
(Scheme_Output_Port*),
|
||||
int must_close);
|
||||
|
||||
Scheme_Object *scheme_make_file_input_port(FILE *fp);
|
||||
Scheme_Object *scheme_make_named_file_input_port(FILE *fp, const char *filename);
|
||||
Scheme_Object *scheme_make_file_output_port(FILE *fp);
|
||||
|
||||
Scheme_Object *scheme_make_string_input_port(const char *str);
|
||||
Scheme_Object *scheme_make_sized_string_input_port(const char *str, long len);
|
||||
Scheme_Object *scheme_make_string_output_port();
|
||||
char *scheme_get_string_output(Scheme_Object *);
|
||||
char *scheme_get_sized_string_output(Scheme_Object *, int *len);
|
||||
|
||||
void scheme_pipe(Scheme_Object **write, Scheme_Object **read);
|
||||
|
||||
int scheme_file_exists(char *filename);
|
||||
int scheme_directory_exists(char *dirname);
|
||||
char *scheme_expand_filename(char* filename, int ilen, char *errorin, int *ex);
|
||||
|
||||
char *scheme_os_getcwd(char *buf, int buflen, int *actlen, int noexn);
|
||||
int scheme_os_setcwd(char *buf, int noexn);
|
||||
char *scheme_getdrive(void);
|
||||
|
||||
Scheme_Object *scheme_split_pathname(const char *path, int len, Scheme_Object **base, int *isdir);
|
||||
Scheme_Object *scheme_build_pathname(int argc, Scheme_Object **argv);
|
||||
|
||||
void *scheme_alloc_fdset_array(int count, int permanent);
|
||||
void *scheme_init_fdset_array(void *fdarray, int count);
|
||||
void *scheme_get_fdset(void *fdarray, int pos);
|
||||
void scheme_fdzero(void *fd);
|
||||
void scheme_fdset(void *fd, int pos);
|
||||
void scheme_fdclr(void *fd, int pos);
|
||||
int scheme_fdisset(void *fd, int pos);
|
||||
void scheme_add_fd_handle(void *h, void *fds, int repost);
|
||||
void scheme_add_fd_eventmask(void *fds, int mask);
|
||||
|
||||
int scheme_return_eof_for_error();
|
||||
|
||||
/*========================================================================*/
|
||||
/* namespace/environment */
|
||||
/*========================================================================*/
|
||||
|
||||
Scheme_Object *scheme_make_namespace(int argc, Scheme_Object *argv[]);
|
||||
void scheme_add_namespace_option(Scheme_Object *key, void (*f)(Scheme_Env *));
|
||||
|
||||
void scheme_add_global(const char *name, Scheme_Object *val, Scheme_Env *env);
|
||||
void scheme_add_global_constant(const char *name, Scheme_Object *v, Scheme_Env *env);
|
||||
void scheme_add_global_keyword(const char *name, Scheme_Object *v, Scheme_Env *env);
|
||||
void scheme_remove_global(const char *name, Scheme_Env *env);
|
||||
void scheme_remove_global_constant(const char *name, Scheme_Env *env);
|
||||
|
||||
void scheme_add_global_symbol(Scheme_Object *name, Scheme_Object *val,
|
||||
Scheme_Env *env);
|
||||
void scheme_remove_global_symbol(Scheme_Object *name, Scheme_Env *env);
|
||||
void scheme_add_global_constant_symbol(Scheme_Object *name, Scheme_Object *v, Scheme_Env *env);
|
||||
|
||||
void scheme_set_keyword(Scheme_Object *name, Scheme_Env *env);
|
||||
|
||||
Scheme_Object *scheme_make_envunbox(Scheme_Object *value);
|
||||
|
||||
Scheme_Object *scheme_lookup_global(Scheme_Object *symbol, Scheme_Env *env);
|
||||
Scheme_Bucket *scheme_global_bucket(Scheme_Object *symbol, Scheme_Env *env);
|
||||
|
||||
void scheme_set_global_bucket(char *proc, Scheme_Bucket *var, Scheme_Object *val,
|
||||
int set_undef);
|
||||
|
||||
/*========================================================================*/
|
||||
/* symbols */
|
||||
/*========================================================================*/
|
||||
|
||||
Scheme_Object *scheme_intern_symbol(const char *name);
|
||||
Scheme_Object *scheme_intern_exact_symbol(const char *name, int len);
|
||||
Scheme_Object *scheme_make_symbol(const char *name); /* Make uninterned */
|
||||
Scheme_Object *scheme_make_exact_symbol(const char *name, int len); /* Exact case */
|
||||
const char *scheme_symbol_name(Scheme_Object *sym);
|
||||
const char *scheme_symbol_name_and_size(Scheme_Object *sym, int *l, int flags);
|
||||
char *scheme_symbol_val(Scheme_Object *sym);
|
||||
|
||||
/*========================================================================*/
|
||||
/* structs */
|
||||
/*========================================================================*/
|
||||
|
||||
Scheme_Object **scheme_make_struct_values(Scheme_Object *struct_type,
|
||||
Scheme_Object **names,
|
||||
int count, int flags);
|
||||
Scheme_Object **scheme_make_struct_names(Scheme_Object *base,
|
||||
Scheme_Object *field_names,
|
||||
int flags, int *count_out);
|
||||
Scheme_Object *scheme_make_struct_type(Scheme_Object *base,
|
||||
Scheme_Object *parent,
|
||||
int num_fields);
|
||||
Scheme_Object *scheme_make_struct_instance(Scheme_Object *stype,
|
||||
int argc,
|
||||
Scheme_Object **argv);
|
||||
int scheme_is_struct_instance(Scheme_Object *type, Scheme_Object *v);
|
||||
Scheme_Object *scheme_struct_ref(Scheme_Object *s, int pos);
|
||||
void scheme_struct_set(Scheme_Object *s, int pos, Scheme_Object *v);
|
||||
|
||||
/*========================================================================*/
|
||||
/* objects */
|
||||
/*========================================================================*/
|
||||
|
||||
#ifndef NO_OBJECT_SYSTEM
|
||||
|
||||
int scheme_is_subclass(Scheme_Object *sub, Scheme_Object *parent);
|
||||
int scheme_is_implementation(Scheme_Object *cl, Scheme_Object *in);
|
||||
int scheme_is_interface_extension(Scheme_Object *n1, Scheme_Object *n2);
|
||||
int scheme_is_a(Scheme_Object *obj, Scheme_Object *sclass);
|
||||
const char *scheme_get_class_name(Scheme_Object *cl, int *len);
|
||||
const char *scheme_get_interface_name(Scheme_Object *cl, int *len);
|
||||
|
||||
Scheme_Object *scheme_make_object(Scheme_Object *sclass,
|
||||
int argc, Scheme_Object **argv);
|
||||
Scheme_Object *scheme_make_uninited_object(Scheme_Object *sclass);
|
||||
|
||||
Scheme_Object *scheme_find_ivar(Scheme_Object *obj, Scheme_Object *sym, int force);
|
||||
|
||||
|
||||
/* OLD class-making interface (Still used by xctocc) */
|
||||
Scheme_Object *scheme_make_class(const char *name, Scheme_Object *sup,
|
||||
Scheme_Method_Prim *init, int num_methods);
|
||||
void scheme_add_method(Scheme_Object *cl, const char *name,
|
||||
Scheme_Method_Prim *f);
|
||||
void scheme_add_method_w_arity(Scheme_Object *cl, const char *name,
|
||||
Scheme_Method_Prim *f, int mina, int maxa);
|
||||
void scheme_made_class(Scheme_Object *cl);
|
||||
Scheme_Object *scheme_class_to_interface(Scheme_Object *cl, char *name);
|
||||
|
||||
/* NEW class-making interface */
|
||||
struct Scheme_Class_Assembly *scheme_make_class_assembly(const char *name, int n_interfaces,
|
||||
int n_public, Scheme_Object **names,
|
||||
int n_override, Scheme_Object **onames,
|
||||
int n_inh, Scheme_Object **inheritd,
|
||||
int n_ren, Scheme_Object **renames,
|
||||
int mina, int maxa,
|
||||
Scheme_Instance_Init_Proc *initproc);
|
||||
Scheme_Object *scheme_create_class(struct Scheme_Class_Assembly *a, void *data,
|
||||
Scheme_Object *super, Scheme_Object **interfaces);
|
||||
|
||||
struct Scheme_Interface_Assembly *scheme_make_interface_assembly(const char *name, int n_supers,
|
||||
int n_names,
|
||||
Scheme_Object **names);
|
||||
Scheme_Object *scheme_create_interface(struct Scheme_Interface_Assembly *a,
|
||||
Scheme_Object **supers);
|
||||
|
||||
Scheme_Object *scheme_apply_generic_data(Scheme_Object *gdata,
|
||||
Scheme_Object *sobj, int force);
|
||||
Scheme_Object *scheme_get_generic_data(Scheme_Object *cl,
|
||||
Scheme_Object *name);
|
||||
#endif
|
||||
|
||||
/*========================================================================*/
|
||||
/* units */
|
||||
/*========================================================================*/
|
||||
|
||||
Scheme_Object *scheme_invoke_unit(Scheme_Object *functor, int num_ins,
|
||||
Scheme_Object **ins, Scheme_Object **anchors,
|
||||
int tail, int multi);
|
||||
|
||||
Scheme_Object *scheme_assemble_compound_unit(Scheme_Object *imports,
|
||||
Scheme_Object *links,
|
||||
Scheme_Object *exports);
|
||||
Scheme_Object *scheme_make_compound_unit(Scheme_Object *data_in,
|
||||
Scheme_Object **subs_in);
|
||||
|
||||
const char *scheme_get_unit_name(Scheme_Object *cl, int *len);
|
||||
|
||||
/*========================================================================*/
|
||||
/* utilities */
|
||||
/*========================================================================*/
|
||||
|
||||
int scheme_eq(Scheme_Object *obj1, Scheme_Object *obj2);
|
||||
int scheme_eqv(Scheme_Object *obj1, Scheme_Object *obj2);
|
||||
int scheme_equal(Scheme_Object *obj1, Scheme_Object *obj2);
|
||||
|
||||
Scheme_Object *scheme_build_list(int argc, Scheme_Object **argv);
|
||||
|
||||
int scheme_list_length(Scheme_Object *list);
|
||||
int scheme_proper_list_length(Scheme_Object *list);
|
||||
|
||||
Scheme_Object *scheme_alloc_list(int size);
|
||||
Scheme_Object *scheme_map_1(Scheme_Object *(*f)(Scheme_Object*),
|
||||
Scheme_Object *l);
|
||||
|
||||
Scheme_Object *scheme_car(Scheme_Object *pair);
|
||||
Scheme_Object *scheme_cdr(Scheme_Object *pair);
|
||||
Scheme_Object *scheme_cadr(Scheme_Object *pair);
|
||||
Scheme_Object *scheme_caddr(Scheme_Object *pair);
|
||||
|
||||
Scheme_Object *scheme_vector_to_list(Scheme_Object *vec);
|
||||
Scheme_Object *scheme_list_to_vector(Scheme_Object *list);
|
||||
|
||||
Scheme_Object *scheme_append(Scheme_Object *lstx, Scheme_Object *lsty);
|
||||
|
||||
Scheme_Object *scheme_box(Scheme_Object *v);
|
||||
Scheme_Object *scheme_unbox(Scheme_Object *obj);
|
||||
void scheme_set_box(Scheme_Object *b, Scheme_Object *v);
|
||||
|
||||
Scheme_Object *scheme_make_weak_box(Scheme_Object *v);
|
||||
|
||||
Scheme_Object *scheme_load(const char *file);
|
||||
Scheme_Object *scheme_load_extension(const char *filename, Scheme_Env *env);
|
||||
void scheme_register_extension_global(void *ptr, long size);
|
||||
|
||||
long scheme_get_milliseconds(void);
|
||||
long scheme_get_process_milliseconds(void);
|
||||
|
||||
void scheme_rep(void);
|
||||
char *scheme_banner(void);
|
||||
char *scheme_version(void);
|
||||
|
||||
int scheme_check_proc_arity(const char *where, int a,
|
||||
int which, int argc, Scheme_Object **argv);
|
||||
|
||||
char *scheme_make_provided_string(Scheme_Object *o, int count, int *len);
|
||||
char *scheme_make_args_string(char *s, int which, int argc, Scheme_Object **argv, long *len);
|
||||
|
||||
void scheme_no_dumps(char *why);
|
||||
|
||||
const char *scheme_system_library_subpath();
|
||||
|
|
@ -1,559 +0,0 @@
|
|||
/*
|
||||
MzScheme
|
||||
Copyright (c) 1995-2000 Matthew Flatt
|
||||
All rights reserved.
|
||||
|
||||
Please see the full copyright in the documentation.
|
||||
|
||||
Originally based on:
|
||||
libscheme
|
||||
Copyright (c) 1994 Brent Benson
|
||||
All rights reserved.
|
||||
*/
|
||||
|
||||
/* MzScheme function prototypes */
|
||||
/* Macros generally shouldn't go in this file; it is used both to
|
||||
prototype functions, and as a parsing source for
|
||||
declaring scheme_extension_table */
|
||||
|
||||
/* The scheme_extension_table "parser" is picky; don't leave a space
|
||||
between a function name and it's opening parameter parenthesis. */
|
||||
|
||||
/* After this START tag, all comments should start & end on same line */
|
||||
|
||||
typedef struct {
|
||||
/*========================================================================*/
|
||||
/* setjmpup (continuations) */
|
||||
/*========================================================================*/
|
||||
void (*scheme_init_jmpup_buf)(Scheme_Jumpup_Buf *b);
|
||||
int (*scheme_setjmpup_relative)(Scheme_Jumpup_Buf *b, void *base,
|
||||
void *start, Scheme_Jumpup_Buf *cont);
|
||||
void (*scheme_longjmpup)(Scheme_Jumpup_Buf *b);
|
||||
void (*scheme_reset_jmpup_buf)(Scheme_Jumpup_Buf *b);
|
||||
#ifdef USE_MZ_SETJMP
|
||||
int (*scheme_setjmp)(mz_jmp_buf b);
|
||||
void (*scheme_longjmp)(mz_jmp_buf b, int v);
|
||||
#endif
|
||||
void (*scheme_clear_escape)(void);
|
||||
/*========================================================================*/
|
||||
/* parameters */
|
||||
/*========================================================================*/
|
||||
Scheme_Object *(*scheme_make_config)(Scheme_Config *base);
|
||||
Scheme_Object *(*scheme_branch_config)(void);
|
||||
int (*scheme_new_param)(void);
|
||||
Scheme_Object *(*scheme_param_config)(char *name, Scheme_Object *pos,
|
||||
int argc, Scheme_Object **argv,
|
||||
int arity,
|
||||
Scheme_Prim *check, char *expected,
|
||||
int isbool);
|
||||
Scheme_Object *(*scheme_register_parameter)(Scheme_Prim *function, char *name, int which);
|
||||
Scheme_Env *(*scheme_get_env)(Scheme_Config *config);
|
||||
/*========================================================================*/
|
||||
/* threads */
|
||||
/*========================================================================*/
|
||||
#ifdef MZ_REAL_THREADS
|
||||
Scheme_Process *(*scheme_get_current_process)();
|
||||
#else
|
||||
#ifndef LINK_EXTENSIONS_BY_TABLE
|
||||
Scheme_Process *scheme_current_process;
|
||||
int scheme_fuel_counter;
|
||||
#else
|
||||
Scheme_Process **scheme_current_process_ptr;
|
||||
int *scheme_fuel_counter_ptr;
|
||||
#endif
|
||||
#endif
|
||||
#ifndef NO_SCHEME_THREADS
|
||||
Scheme_Object *(*scheme_thread)(Scheme_Object *thunk, Scheme_Config *config);
|
||||
Scheme_Object *(*scheme_thread_w_manager)(Scheme_Object *thunk, Scheme_Config *config,
|
||||
Scheme_Manager *mgr);
|
||||
void (*scheme_kill_thread)(Scheme_Process *p);
|
||||
#endif
|
||||
void (*scheme_break_thread)(Scheme_Process *p);
|
||||
#ifndef MZ_REAL_THREADS
|
||||
void (*scheme_process_block)(float sleep_time);
|
||||
void (*scheme_swap_process)(Scheme_Process *process);
|
||||
#else
|
||||
void (*scheme_process_block_w_process)(float sleep_time, Scheme_Process *p);
|
||||
#endif
|
||||
void (*scheme_weak_suspend_thread)(Scheme_Process *p);
|
||||
void (*scheme_weak_resume_thread)(Scheme_Process *p);
|
||||
int (*scheme_block_until)(int (*f)(Scheme_Object *), void (*fdfd)(Scheme_Object *, void *), void *, float);
|
||||
int (*scheme_in_main_thread)(void);
|
||||
int (*scheme_tls_allocate)();
|
||||
void (*scheme_tls_set)(int pos, void *v);
|
||||
void *(*scheme_tls_get)(int pos);
|
||||
Scheme_Manager *(*scheme_make_manager)(Scheme_Manager *);
|
||||
Scheme_Manager_Reference *(*scheme_add_managed)(Scheme_Manager *m, Scheme_Object *o,
|
||||
Scheme_Close_Manager_Client *f, void *data,
|
||||
int strong);
|
||||
void (*scheme_remove_managed)(Scheme_Manager_Reference *m, Scheme_Object *o);
|
||||
void (*scheme_close_managed)(Scheme_Manager *m);
|
||||
/*========================================================================*/
|
||||
/* error handling */
|
||||
/*========================================================================*/
|
||||
void (*scheme_signal_error)(char *msg, ...);
|
||||
void (*scheme_raise_exn)(int exnid, ...);
|
||||
void (*scheme_warning)(char *msg, ...);
|
||||
void (*scheme_wrong_count)(const char *name, int minc, int maxc, int argc,
|
||||
Scheme_Object **argv);
|
||||
void (*scheme_case_lambda_wrong_count)(const char *name, int argc,
|
||||
Scheme_Object **argv, int count, ...);
|
||||
void (*scheme_wrong_type)(const char *name, const char *expected,
|
||||
int which, int argc,
|
||||
Scheme_Object **argv);
|
||||
void (*scheme_arg_mismatch)(const char *name, const char *msg, Scheme_Object *o);
|
||||
void (*scheme_wrong_return_arity)(const char *where,
|
||||
int expected, int got,
|
||||
Scheme_Object **argv,
|
||||
const char *context_detail, ...);
|
||||
void (*scheme_unbound_global)(Scheme_Object *name) ;
|
||||
Scheme_Object *(*scheme_dynamic_wind)(void (*pre)(void *),
|
||||
Scheme_Object *(*act)(void *),
|
||||
void (*post)(void *),
|
||||
Scheme_Object *(*jmp_handler)(void *),
|
||||
void *data);
|
||||
/*========================================================================*/
|
||||
/* types */
|
||||
/*========================================================================*/
|
||||
Scheme_Type (*scheme_make_type)(const char *name);
|
||||
/* Type readers & writers for compiled code data */
|
||||
void (*scheme_install_type_reader)(Scheme_Type type, Scheme_Type_Reader f);
|
||||
void (*scheme_install_type_writer)(Scheme_Type type, Scheme_Type_Writer f);
|
||||
/*========================================================================*/
|
||||
/* constants */
|
||||
/*========================================================================*/
|
||||
Scheme_Object *scheme_eof;
|
||||
Scheme_Object *scheme_null;
|
||||
Scheme_Object *scheme_true;
|
||||
Scheme_Object *scheme_false;
|
||||
Scheme_Object *scheme_void;
|
||||
Scheme_Object *scheme_undefined;
|
||||
Scheme_Object *scheme_tail_call_waiting;
|
||||
Scheme_Object *scheme_multiple_values;
|
||||
/*========================================================================*/
|
||||
/* evaluation */
|
||||
/*========================================================================*/
|
||||
Scheme_Object *(*scheme_eval)(Scheme_Object *obj, Scheme_Env *env);
|
||||
Scheme_Object *(*scheme_eval_multi)(Scheme_Object *obj, Scheme_Env *env);
|
||||
Scheme_Object *(*scheme_eval_compiled)(Scheme_Object *obj);
|
||||
Scheme_Object *(*scheme_eval_compiled_multi)(Scheme_Object *obj);
|
||||
Scheme_Object *(*_scheme_eval_compiled)(Scheme_Object *obj);
|
||||
Scheme_Object *(*_scheme_eval_compiled_multi)(Scheme_Object *obj);
|
||||
#ifndef MZ_REAL_THREADS
|
||||
Scheme_Object *(*scheme_apply)(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
|
||||
Scheme_Object *(*scheme_apply_multi)(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
|
||||
Scheme_Object *(*scheme_apply_eb)(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
|
||||
Scheme_Object *(*scheme_apply_multi_eb)(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
|
||||
#else
|
||||
Scheme_Object *(*scheme_apply_wp)(Scheme_Object *rator, int num_rands, Scheme_Object **rands,
|
||||
Scheme_Process *p);
|
||||
Scheme_Object *(*scheme_apply_multi_wp)(Scheme_Object *rator, int num_rands, Scheme_Object **rands,
|
||||
Scheme_Process *p);
|
||||
Scheme_Object *(*scheme_apply_eb_wp)(Scheme_Object *rator, int num_rands, Scheme_Object **rands,
|
||||
Scheme_Process *p);
|
||||
Scheme_Object *(*scheme_apply_multi_eb_wp)(Scheme_Object *rator, int num_rands, Scheme_Object **rands,
|
||||
Scheme_Process *p);
|
||||
#endif
|
||||
Scheme_Object *(*scheme_apply_to_list)(Scheme_Object *rator, Scheme_Object *argss);
|
||||
Scheme_Object *(*scheme_eval_string)(const char *str, Scheme_Env *env);
|
||||
Scheme_Object *(*scheme_eval_string_multi)(const char *str, Scheme_Env *env);
|
||||
Scheme_Object *(*scheme_eval_string_all)(const char *str, Scheme_Env *env, int all);
|
||||
Scheme_Object *(*_scheme_apply_known_closed_prim)(Scheme_Object *rator, int argc,
|
||||
Scheme_Object **argv);
|
||||
Scheme_Object *(*_scheme_apply_known_closed_prim_multi)(Scheme_Object *rator, int argc,
|
||||
Scheme_Object **argv);
|
||||
Scheme_Object *(*_scheme_apply_closed_prim)(Scheme_Object *rator, int argc,
|
||||
Scheme_Object **argv);
|
||||
Scheme_Object *(*_scheme_apply_closed_prim_multi)(Scheme_Object *rator, int argc,
|
||||
Scheme_Object **argv);
|
||||
Scheme_Object *(*scheme_values)(int c, Scheme_Object **v);
|
||||
Scheme_Object *(*scheme_check_one_value)(Scheme_Object *v);
|
||||
/* Tail calls - only use these when you're writing new functions/syntax */
|
||||
Scheme_Object *(*scheme_tail_apply)(Scheme_Object *f, int n, Scheme_Object **arg);
|
||||
Scheme_Object *(*scheme_tail_apply_no_copy)(Scheme_Object *f, int n, Scheme_Object **arg);
|
||||
Scheme_Object *(*scheme_tail_apply_to_list)(Scheme_Object *f, Scheme_Object *l);
|
||||
Scheme_Object *(*scheme_tail_eval_expr)(Scheme_Object *obj);
|
||||
void (*scheme_set_tail_buffer_size)(int s);
|
||||
Scheme_Object *(*scheme_force_value)(Scheme_Object *);
|
||||
void (*scheme_set_cont_mark)(Scheme_Object *key, Scheme_Object *val);
|
||||
void (*scheme_push_continuation_frame)(Scheme_Cont_Frame_Data *);
|
||||
void (*scheme_pop_continuation_frame)(Scheme_Cont_Frame_Data *);
|
||||
void (*scheme_temp_dec_mark_depth)();
|
||||
void (*scheme_temp_inc_mark_depth)();
|
||||
Scheme_Object *(*scheme_current_continuation_marks)(void);
|
||||
/* Internal */
|
||||
#ifndef MZ_REAL_THREADS
|
||||
Scheme_Object *(*scheme_do_eval)(Scheme_Object *obj, int _num_rands, Scheme_Object **rands, int val);
|
||||
#else
|
||||
Scheme_Object *(*scheme_do_eval_w_process)(Scheme_Object *obj, int _num_rands, Scheme_Object **rands, int val, Scheme_Process *p);
|
||||
#endif
|
||||
/*========================================================================*/
|
||||
/* memory management */
|
||||
/*========================================================================*/
|
||||
/* The core allocator functions depend on the GC. Macros in scheme.h */
|
||||
/* map to the apporpriate core allocation function. */
|
||||
#ifndef SCHEME_NO_GC
|
||||
# ifndef SCHEME_NO_GC_PROTO
|
||||
void *(*GC_malloc)(size_t size_in_bytes);
|
||||
void *(*GC_malloc_atomic)(size_t size_in_bytes);
|
||||
# ifdef MZ_PRECISE_GC
|
||||
void *(*GC_malloc_one_tagged)(size_t size_in_bytes);
|
||||
void *(*GC_malloc_atomic_uncollectable)(size_t size_in_bytes);
|
||||
void *(*GC_malloc_array_tagged)(size_t size_in_bytes);
|
||||
# else
|
||||
void *(*GC_malloc_stubborn)(size_t size_in_bytes);
|
||||
void *(*GC_malloc_uncollectable)(size_t size_in_bytes);
|
||||
# endif
|
||||
# endif
|
||||
#endif
|
||||
void *(*scheme_malloc_eternal)(size_t n);
|
||||
void (*scheme_end_stubborn_change)(void *p);
|
||||
void *(*scheme_calloc)(size_t num, size_t size);
|
||||
char *(*scheme_strdup)(const char *str);
|
||||
char *(*scheme_strdup_eternal)(const char *str);
|
||||
void *(*scheme_malloc_fail_ok)(void *(*f)(size_t), size_t);
|
||||
void (*scheme_weak_reference)(void **p);
|
||||
void (*scheme_weak_reference_indirect)(void **p, void *v);
|
||||
void (*scheme_unweak_reference)(void **p);
|
||||
void (*scheme_add_finalizer)(void *p, void (*f)(void *p, void *data), void *data);
|
||||
void (*scheme_add_finalizer_once)(void *p, void (*f)(void *p, void *data), void *data);
|
||||
void (*scheme_add_scheme_finalizer)(void *p, void (*f)(void *p, void *data), void *data);
|
||||
void (*scheme_add_scheme_finalizer_once)(void *p, void (*f)(void *p, void *data), void *data);
|
||||
void (*scheme_register_finalizer)(void *p,
|
||||
void (*f)(void *p, void *data), void *data,
|
||||
void (**oldf)(void *p, void *data),
|
||||
void **olddata);
|
||||
void (*scheme_remove_all_finalization)(void *p);
|
||||
void (*scheme_dont_gc_ptr)(void *p);
|
||||
void (*scheme_gc_ptr_ok)(void *p);
|
||||
void (*scheme_collect_garbage)(void);
|
||||
/*========================================================================*/
|
||||
/* hash tables */
|
||||
/*========================================================================*/
|
||||
Scheme_Hash_Table *(*scheme_hash_table)(int size, int type,
|
||||
int w_const, int forever);
|
||||
void (*scheme_add_to_table)(Scheme_Hash_Table *table, const char *key, void *val, int);
|
||||
void (*scheme_change_in_table)(Scheme_Hash_Table *table, const char *key, void *new_val);
|
||||
void *(*scheme_lookup_in_table)(Scheme_Hash_Table *table, const char *key);
|
||||
Scheme_Bucket *(*scheme_bucket_from_table)(Scheme_Hash_Table *table, const char *key);
|
||||
/*========================================================================*/
|
||||
/* basic Scheme value constructors */
|
||||
/*========================================================================*/
|
||||
Scheme_Object *(*scheme_make_prim)(Scheme_Prim *prim);
|
||||
Scheme_Object *(*scheme_make_noneternal_prim)(Scheme_Prim *prim);
|
||||
Scheme_Object *(*scheme_make_closed_prim)(Scheme_Closed_Prim *prim, void *data);
|
||||
Scheme_Object *(*scheme_make_prim_w_arity)(Scheme_Prim *prim, const char *name,
|
||||
short mina, short maxa);
|
||||
Scheme_Object *(*scheme_make_folding_prim)(Scheme_Prim *prim,
|
||||
const char *name,
|
||||
short mina, short maxa,
|
||||
short functional);
|
||||
Scheme_Object *(*scheme_make_noneternal_prim_w_arity)(Scheme_Prim *prim,
|
||||
const char *name,
|
||||
short mina, short maxa);
|
||||
Scheme_Object *(*scheme_make_closed_prim_w_arity)(Scheme_Closed_Prim *prim,
|
||||
void *data, const char *name,
|
||||
short mina, short maxa);
|
||||
Scheme_Object *(*scheme_make_folding_closed_prim)(Scheme_Closed_Prim *prim,
|
||||
void *data, const char *name,
|
||||
short mina, short maxa,
|
||||
short functional);
|
||||
Scheme_Object *(*scheme_make_closure)(Scheme_Env *env, Scheme_Object *code);
|
||||
Scheme_Object *(*scheme_make_pair)(Scheme_Object *car, Scheme_Object *cdr);
|
||||
Scheme_Object *(*scheme_make_string)(const char *chars);
|
||||
Scheme_Object *(*scheme_make_sized_string)(char *chars, long len, int copy);
|
||||
Scheme_Object *(*scheme_make_sized_offset_string)(char *chars, long d, long len, int copy);
|
||||
Scheme_Object *(*scheme_make_immutable_sized_string)(char *chars, long len, int copy);
|
||||
Scheme_Object *(*scheme_make_string_without_copying)(char *chars);
|
||||
Scheme_Object *(*scheme_alloc_string)(int size, char fill);
|
||||
Scheme_Object *(*scheme_append_string)(Scheme_Object *, Scheme_Object *);
|
||||
Scheme_Object *(*scheme_make_vector)(int size, Scheme_Object *fill);
|
||||
Scheme_Object *(*scheme_make_integer_value)(long i);
|
||||
Scheme_Object *(*scheme_make_integer_value_from_unsigned)(unsigned long i);
|
||||
Scheme_Object *(*scheme_make_double)(double d);
|
||||
#ifdef MZ_USE_SINGLE_FLOATS
|
||||
Scheme_Object *(*scheme_make_float)(float f) ;
|
||||
#endif
|
||||
Scheme_Object *(*scheme_make_char)(char ch);
|
||||
Scheme_Object *(*scheme_make_promise)(Scheme_Object *expr, Scheme_Env *env);
|
||||
Scheme_Object *(*scheme_make_promise_from_thunk)(Scheme_Object *expr);
|
||||
#ifndef NO_SCHEME_THREADS
|
||||
Scheme_Object *(*scheme_make_sema)(long v);
|
||||
void (*scheme_post_sema)(Scheme_Object *o);
|
||||
int (*scheme_wait_sema)(Scheme_Object *o, int just_try);
|
||||
#endif
|
||||
Scheme_Object **scheme_char_constants;
|
||||
int (*scheme_get_int_val)(Scheme_Object *o, long *v);
|
||||
int (*scheme_get_unsigned_int_val)(Scheme_Object *o, unsigned long *v);
|
||||
double (*scheme_real_to_double)(Scheme_Object *r);
|
||||
const char *(*scheme_get_proc_name)(Scheme_Object *p, int *len, int for_error);
|
||||
/*========================================================================*/
|
||||
/* bignums */
|
||||
/*========================================================================*/
|
||||
Scheme_Object *(*scheme_make_bignum)(long v);
|
||||
Scheme_Object *(*scheme_make_bignum_from_unsigned)(unsigned long v);
|
||||
double (*scheme_bignum_to_double)(const Scheme_Object *n);
|
||||
Scheme_Object *(*scheme_bignum_from_double)(double d);
|
||||
#ifdef MZ_USE_SINGLE_FLOATS
|
||||
float (*scheme_bignum_to_float)(const Scheme_Object *n);
|
||||
Scheme_Object *(*scheme_bignum_from_float)(float d);
|
||||
#else
|
||||
# define scheme_bignum_to_float scheme_bignum_to_double
|
||||
# define scheme_bignum_from_float scheme_bignum_from_double
|
||||
#endif
|
||||
char *(*scheme_bignum_to_string)(const Scheme_Object *n, int radix);
|
||||
Scheme_Object *(*scheme_read_bignum)(const char *str, int offset, int radix);
|
||||
Scheme_Object *(*scheme_bignum_normalize)(const Scheme_Object *n);
|
||||
long (*scheme_double_to_int)(const char *where, double d) ;
|
||||
/*========================================================================*/
|
||||
/* rationals */
|
||||
/*========================================================================*/
|
||||
Scheme_Object *(*scheme_make_rational)(const Scheme_Object *r, const Scheme_Object *d);
|
||||
double (*scheme_rational_to_double)(const Scheme_Object *n);
|
||||
Scheme_Object *(*scheme_rational_from_double)(double d);
|
||||
#ifdef MZ_USE_SINGLE_FLOATS
|
||||
float (*scheme_rational_to_float)(const Scheme_Object *n);
|
||||
Scheme_Object *(*scheme_rational_from_float)(float d);
|
||||
#else
|
||||
# define scheme_rational_to_float scheme_rational_to_double
|
||||
# define scheme_rational_from_float scheme_rational_from_double
|
||||
#endif
|
||||
Scheme_Object *(*scheme_rational_normalize)(const Scheme_Object *n);
|
||||
Scheme_Object *(*scheme_rational_numerator)(const Scheme_Object *n);
|
||||
Scheme_Object *(*scheme_rational_denominator)(const Scheme_Object *n);
|
||||
/*========================================================================*/
|
||||
/* complexes */
|
||||
/*========================================================================*/
|
||||
Scheme_Object *(*scheme_make_complex)(const Scheme_Object *r, const Scheme_Object *i);
|
||||
Scheme_Object *(*scheme_complex_normalize)(const Scheme_Object *n);
|
||||
Scheme_Object *(*scheme_complex_real_part)(const Scheme_Object *n);
|
||||
Scheme_Object *(*scheme_complex_imaginary_part)(const Scheme_Object *n);
|
||||
/* Exact/inexact: */
|
||||
int (*scheme_is_exact)(Scheme_Object *n);
|
||||
int (*scheme_is_inexact)(Scheme_Object *n);
|
||||
/*========================================================================*/
|
||||
/* macros, syntax, and compilation */
|
||||
/*========================================================================*/
|
||||
Scheme_Object *(*scheme_expand)(Scheme_Object *form, Scheme_Env *env);
|
||||
Scheme_Object *(*scheme_compile)(Scheme_Object *form, Scheme_Env *env, int writeable);
|
||||
Scheme_Object *(*scheme_make_promise_value)(Scheme_Object *compiled_expr);
|
||||
/*========================================================================*/
|
||||
/* ports */
|
||||
/*========================================================================*/
|
||||
Scheme_Object *(*scheme_read)(Scheme_Object *port);
|
||||
void (*scheme_write)(Scheme_Object *obj, Scheme_Object *port);
|
||||
void (*scheme_display)(Scheme_Object *obj, Scheme_Object *port);
|
||||
void (*scheme_write_w_max)(Scheme_Object *obj, Scheme_Object *port, long maxl);
|
||||
void (*scheme_display_w_max)(Scheme_Object *obj, Scheme_Object *port, long maxl);
|
||||
void (*scheme_write_string)(const char *str, long len, Scheme_Object *port);
|
||||
void (*scheme_write_offset_string)(const char *str, long d, long len, Scheme_Object *port);
|
||||
char *(*scheme_write_to_string)(Scheme_Object *obj, long *len);
|
||||
char *(*scheme_display_to_string)(Scheme_Object *obj, long *len);
|
||||
char *(*scheme_write_to_string_w_max)(Scheme_Object *obj, long *len, long maxl);
|
||||
char *(*scheme_display_to_string_w_max)(Scheme_Object *obj, long *len, long maxl);
|
||||
void (*scheme_debug_print)(Scheme_Object *obj);
|
||||
void (*scheme_flush_output)(Scheme_Object *port);
|
||||
char *(*scheme_format)(char *format, int flen, int argc, Scheme_Object **argv, int *rlen);
|
||||
void (*scheme_printf)(char *format, int flen, int argc, Scheme_Object **argv);
|
||||
int (*scheme_getc)(Scheme_Object *port);
|
||||
int (*scheme_peekc)(Scheme_Object *port);
|
||||
void (*scheme_ungetc)(int ch, Scheme_Object *port);
|
||||
int (*scheme_char_ready)(Scheme_Object *port);
|
||||
int (*scheme_peekc_is_ungetc)(Scheme_Object *port);
|
||||
void (*scheme_need_wakeup)(Scheme_Object *port, void *fds);
|
||||
long (*scheme_get_chars)(Scheme_Object *port, long size, char *buffer, int offset);
|
||||
long (*scheme_tell)(Scheme_Object *port);
|
||||
long (*scheme_output_tell)(Scheme_Object *port);
|
||||
long (*scheme_tell_line)(Scheme_Object *port);
|
||||
void (*scheme_count_lines)(Scheme_Object *port);
|
||||
void (*scheme_close_input_port)(Scheme_Object *port);
|
||||
void (*scheme_close_output_port)(Scheme_Object *port);
|
||||
int (*scheme_are_all_chars_ready)(Scheme_Object *port);
|
||||
Scheme_Object *(*scheme_make_port_type)(const char *name);
|
||||
Scheme_Input_Port *(*scheme_make_input_port)(Scheme_Object *subtype, void *data,
|
||||
int (*getc_fun)(Scheme_Input_Port*),
|
||||
int (*peekc_fun)(Scheme_Input_Port*),
|
||||
int (*char_ready_fun)
|
||||
(Scheme_Input_Port*),
|
||||
void (*close_fun)
|
||||
(Scheme_Input_Port*),
|
||||
void (*need_wakeup_fun)
|
||||
(Scheme_Input_Port*, void *),
|
||||
int must_close);
|
||||
Scheme_Output_Port *(*scheme_make_output_port)(Scheme_Object *subtype,
|
||||
void *data,
|
||||
void (*write_string_fun)
|
||||
(char*, long, long, Scheme_Output_Port*),
|
||||
void (*close_fun)
|
||||
(Scheme_Output_Port*),
|
||||
int must_close);
|
||||
Scheme_Object *(*scheme_make_file_input_port)(FILE *fp);
|
||||
Scheme_Object *(*scheme_make_named_file_input_port)(FILE *fp, const char *filename);
|
||||
Scheme_Object *(*scheme_make_file_output_port)(FILE *fp);
|
||||
Scheme_Object *(*scheme_make_string_input_port)(const char *str);
|
||||
Scheme_Object *(*scheme_make_sized_string_input_port)(const char *str, long len);
|
||||
Scheme_Object *(*scheme_make_string_output_port)();
|
||||
char *(*scheme_get_string_output)(Scheme_Object *);
|
||||
char *(*scheme_get_sized_string_output)(Scheme_Object *, int *len);
|
||||
void (*scheme_pipe)(Scheme_Object **write, Scheme_Object **read);
|
||||
int (*scheme_file_exists)(char *filename);
|
||||
int (*scheme_directory_exists)(char *dirname);
|
||||
char *(*scheme_expand_filename)(char* filename, int ilen, char *errorin, int *ex);
|
||||
char *(*scheme_os_getcwd)(char *buf, int buflen, int *actlen, int noexn);
|
||||
int (*scheme_os_setcwd)(char *buf, int noexn);
|
||||
char *(*scheme_getdrive)(void);
|
||||
Scheme_Object *(*scheme_split_pathname)(const char *path, int len, Scheme_Object **base, int *isdir);
|
||||
Scheme_Object *(*scheme_build_pathname)(int argc, Scheme_Object **argv);
|
||||
void *(*scheme_alloc_fdset_array)(int count, int permanent);
|
||||
void *(*scheme_init_fdset_array)(void *fdarray, int count);
|
||||
void *(*scheme_get_fdset)(void *fdarray, int pos);
|
||||
void (*scheme_fdzero)(void *fd);
|
||||
void (*scheme_fdset)(void *fd, int pos);
|
||||
void (*scheme_fdclr)(void *fd, int pos);
|
||||
int (*scheme_fdisset)(void *fd, int pos);
|
||||
void (*scheme_add_fd_handle)(void *h, void *fds, int repost);
|
||||
void (*scheme_add_fd_eventmask)(void *fds, int mask);
|
||||
int (*scheme_return_eof_for_error)();
|
||||
/*========================================================================*/
|
||||
/* namespace/environment */
|
||||
/*========================================================================*/
|
||||
Scheme_Object *(*scheme_make_namespace)(int argc, Scheme_Object *argv[]);
|
||||
void (*scheme_add_namespace_option)(Scheme_Object *key, void (*f)(Scheme_Env *));
|
||||
void (*scheme_add_global)(const char *name, Scheme_Object *val, Scheme_Env *env);
|
||||
void (*scheme_add_global_constant)(const char *name, Scheme_Object *v, Scheme_Env *env);
|
||||
void (*scheme_add_global_keyword)(const char *name, Scheme_Object *v, Scheme_Env *env);
|
||||
void (*scheme_remove_global)(const char *name, Scheme_Env *env);
|
||||
void (*scheme_remove_global_constant)(const char *name, Scheme_Env *env);
|
||||
void (*scheme_add_global_symbol)(Scheme_Object *name, Scheme_Object *val,
|
||||
Scheme_Env *env);
|
||||
void (*scheme_remove_global_symbol)(Scheme_Object *name, Scheme_Env *env);
|
||||
void (*scheme_add_global_constant_symbol)(Scheme_Object *name, Scheme_Object *v, Scheme_Env *env);
|
||||
void (*scheme_set_keyword)(Scheme_Object *name, Scheme_Env *env);
|
||||
Scheme_Object *(*scheme_make_envunbox)(Scheme_Object *value);
|
||||
Scheme_Object *(*scheme_lookup_global)(Scheme_Object *symbol, Scheme_Env *env);
|
||||
Scheme_Bucket *(*scheme_global_bucket)(Scheme_Object *symbol, Scheme_Env *env);
|
||||
void (*scheme_set_global_bucket)(char *proc, Scheme_Bucket *var, Scheme_Object *val,
|
||||
int set_undef);
|
||||
/*========================================================================*/
|
||||
/* symbols */
|
||||
/*========================================================================*/
|
||||
Scheme_Object *(*scheme_intern_symbol)(const char *name);
|
||||
Scheme_Object *(*scheme_intern_exact_symbol)(const char *name, int len);
|
||||
Scheme_Object *(*scheme_make_symbol)(const char *name); /* Make uninterned */
|
||||
Scheme_Object *(*scheme_make_exact_symbol)(const char *name, int len); /* Exact case */
|
||||
const char *(*scheme_symbol_name)(Scheme_Object *sym);
|
||||
const char *(*scheme_symbol_name_and_size)(Scheme_Object *sym, int *l, int flags);
|
||||
char *(*scheme_symbol_val)(Scheme_Object *sym);
|
||||
/*========================================================================*/
|
||||
/* structs */
|
||||
/*========================================================================*/
|
||||
Scheme_Object **(*scheme_make_struct_values)(Scheme_Object *struct_type,
|
||||
Scheme_Object **names,
|
||||
int count, int flags);
|
||||
Scheme_Object **(*scheme_make_struct_names)(Scheme_Object *base,
|
||||
Scheme_Object *field_names,
|
||||
int flags, int *count_out);
|
||||
Scheme_Object *(*scheme_make_struct_type)(Scheme_Object *base,
|
||||
Scheme_Object *parent,
|
||||
int num_fields);
|
||||
Scheme_Object *(*scheme_make_struct_instance)(Scheme_Object *stype,
|
||||
int argc,
|
||||
Scheme_Object **argv);
|
||||
int (*scheme_is_struct_instance)(Scheme_Object *type, Scheme_Object *v);
|
||||
Scheme_Object *(*scheme_struct_ref)(Scheme_Object *s, int pos);
|
||||
void (*scheme_struct_set)(Scheme_Object *s, int pos, Scheme_Object *v);
|
||||
/*========================================================================*/
|
||||
/* objects */
|
||||
/*========================================================================*/
|
||||
#ifndef NO_OBJECT_SYSTEM
|
||||
int (*scheme_is_subclass)(Scheme_Object *sub, Scheme_Object *parent);
|
||||
int (*scheme_is_implementation)(Scheme_Object *cl, Scheme_Object *in);
|
||||
int (*scheme_is_interface_extension)(Scheme_Object *n1, Scheme_Object *n2);
|
||||
int (*scheme_is_a)(Scheme_Object *obj, Scheme_Object *sclass);
|
||||
const char *(*scheme_get_class_name)(Scheme_Object *cl, int *len);
|
||||
const char *(*scheme_get_interface_name)(Scheme_Object *cl, int *len);
|
||||
Scheme_Object *(*scheme_make_object)(Scheme_Object *sclass,
|
||||
int argc, Scheme_Object **argv);
|
||||
Scheme_Object *(*scheme_make_uninited_object)(Scheme_Object *sclass);
|
||||
Scheme_Object *(*scheme_find_ivar)(Scheme_Object *obj, Scheme_Object *sym, int force);
|
||||
/* OLD class-making interface (Still used by xctocc) */
|
||||
Scheme_Object *(*scheme_make_class)(const char *name, Scheme_Object *sup,
|
||||
Scheme_Method_Prim *init, int num_methods);
|
||||
void (*scheme_add_method)(Scheme_Object *cl, const char *name,
|
||||
Scheme_Method_Prim *f);
|
||||
void (*scheme_add_method_w_arity)(Scheme_Object *cl, const char *name,
|
||||
Scheme_Method_Prim *f, int mina, int maxa);
|
||||
void (*scheme_made_class)(Scheme_Object *cl);
|
||||
Scheme_Object *(*scheme_class_to_interface)(Scheme_Object *cl, char *name);
|
||||
/* NEW class-making interface */
|
||||
struct Scheme_Class_Assembly *(*scheme_make_class_assembly)(const char *name, int n_interfaces,
|
||||
int n_public, Scheme_Object **names,
|
||||
int n_override, Scheme_Object **onames,
|
||||
int n_inh, Scheme_Object **inheritd,
|
||||
int n_ren, Scheme_Object **renames,
|
||||
int mina, int maxa,
|
||||
Scheme_Instance_Init_Proc *initproc);
|
||||
Scheme_Object *(*scheme_create_class)(struct Scheme_Class_Assembly *a, void *data,
|
||||
Scheme_Object *super, Scheme_Object **interfaces);
|
||||
struct Scheme_Interface_Assembly *(*scheme_make_interface_assembly)(const char *name, int n_supers,
|
||||
int n_names,
|
||||
Scheme_Object **names);
|
||||
Scheme_Object *(*scheme_create_interface)(struct Scheme_Interface_Assembly *a,
|
||||
Scheme_Object **supers);
|
||||
Scheme_Object *(*scheme_apply_generic_data)(Scheme_Object *gdata,
|
||||
Scheme_Object *sobj, int force);
|
||||
Scheme_Object *(*scheme_get_generic_data)(Scheme_Object *cl,
|
||||
Scheme_Object *name);
|
||||
#endif
|
||||
/*========================================================================*/
|
||||
/* units */
|
||||
/*========================================================================*/
|
||||
Scheme_Object *(*scheme_invoke_unit)(Scheme_Object *functor, int num_ins,
|
||||
Scheme_Object **ins, Scheme_Object **anchors,
|
||||
int tail, int multi);
|
||||
Scheme_Object *(*scheme_assemble_compound_unit)(Scheme_Object *imports,
|
||||
Scheme_Object *links,
|
||||
Scheme_Object *exports);
|
||||
Scheme_Object *(*scheme_make_compound_unit)(Scheme_Object *data_in,
|
||||
Scheme_Object **subs_in);
|
||||
const char *(*scheme_get_unit_name)(Scheme_Object *cl, int *len);
|
||||
/*========================================================================*/
|
||||
/* utilities */
|
||||
/*========================================================================*/
|
||||
int (*scheme_eq)(Scheme_Object *obj1, Scheme_Object *obj2);
|
||||
int (*scheme_eqv)(Scheme_Object *obj1, Scheme_Object *obj2);
|
||||
int (*scheme_equal)(Scheme_Object *obj1, Scheme_Object *obj2);
|
||||
Scheme_Object *(*scheme_build_list)(int argc, Scheme_Object **argv);
|
||||
int (*scheme_list_length)(Scheme_Object *list);
|
||||
int (*scheme_proper_list_length)(Scheme_Object *list);
|
||||
Scheme_Object *(*scheme_alloc_list)(int size);
|
||||
Scheme_Object *(*scheme_map_1)(Scheme_Object *(*f)(Scheme_Object*),
|
||||
Scheme_Object *l);
|
||||
Scheme_Object *(*scheme_car)(Scheme_Object *pair);
|
||||
Scheme_Object *(*scheme_cdr)(Scheme_Object *pair);
|
||||
Scheme_Object *(*scheme_cadr)(Scheme_Object *pair);
|
||||
Scheme_Object *(*scheme_caddr)(Scheme_Object *pair);
|
||||
Scheme_Object *(*scheme_vector_to_list)(Scheme_Object *vec);
|
||||
Scheme_Object *(*scheme_list_to_vector)(Scheme_Object *list);
|
||||
Scheme_Object *(*scheme_append)(Scheme_Object *lstx, Scheme_Object *lsty);
|
||||
Scheme_Object *(*scheme_box)(Scheme_Object *v);
|
||||
Scheme_Object *(*scheme_unbox)(Scheme_Object *obj);
|
||||
void (*scheme_set_box)(Scheme_Object *b, Scheme_Object *v);
|
||||
Scheme_Object *(*scheme_make_weak_box)(Scheme_Object *v);
|
||||
Scheme_Object *(*scheme_load)(const char *file);
|
||||
Scheme_Object *(*scheme_load_extension)(const char *filename, Scheme_Env *env);
|
||||
void (*scheme_register_extension_global)(void *ptr, long size);
|
||||
long (*scheme_get_milliseconds)(void);
|
||||
long (*scheme_get_process_milliseconds)(void);
|
||||
void (*scheme_rep)(void);
|
||||
char *(*scheme_banner)(void);
|
||||
char *(*scheme_version)(void);
|
||||
int (*scheme_check_proc_arity)(const char *where, int a,
|
||||
int which, int argc, Scheme_Object **argv);
|
||||
char *(*scheme_make_provided_string)(Scheme_Object *o, int count, int *len);
|
||||
char *(*scheme_make_args_string)(char *s, int which, int argc, Scheme_Object **argv, long *len);
|
||||
void (*scheme_no_dumps)(char *why);
|
||||
const char *(*scheme_system_library_subpath)();
|
||||
#ifndef SCHEME_EX_INLINE
|
||||
} Scheme_Extension_Table;
|
||||
#endif
|
||||
|
|
@ -1,371 +0,0 @@
|
|||
#define scheme_init_jmpup_buf (scheme_extension_table->scheme_init_jmpup_buf)
|
||||
#define scheme_setjmpup_relative (scheme_extension_table->scheme_setjmpup_relative)
|
||||
#define scheme_longjmpup (scheme_extension_table->scheme_longjmpup)
|
||||
#define scheme_reset_jmpup_buf (scheme_extension_table->scheme_reset_jmpup_buf)
|
||||
#ifdef USE_MZ_SETJMP
|
||||
#define scheme_setjmp (scheme_extension_table->scheme_setjmp)
|
||||
#define scheme_longjmp (scheme_extension_table->scheme_longjmp)
|
||||
#endif
|
||||
#define scheme_clear_escape (scheme_extension_table->scheme_clear_escape)
|
||||
#define scheme_make_config (scheme_extension_table->scheme_make_config)
|
||||
#define scheme_branch_config (scheme_extension_table->scheme_branch_config)
|
||||
#define scheme_new_param (scheme_extension_table->scheme_new_param)
|
||||
#define scheme_param_config (scheme_extension_table->scheme_param_config)
|
||||
#define scheme_register_parameter (scheme_extension_table->scheme_register_parameter)
|
||||
#define scheme_get_env (scheme_extension_table->scheme_get_env)
|
||||
#ifdef MZ_REAL_THREADS
|
||||
#define scheme_get_current_process (scheme_extension_table->scheme_get_current_process)
|
||||
#else
|
||||
#ifndef LINK_EXTENSIONS_BY_TABLE
|
||||
#define scheme_current_process (scheme_extension_table->scheme_current_process)
|
||||
#define scheme_fuel_counter (scheme_extension_table->scheme_fuel_counter)
|
||||
#else
|
||||
#define scheme_current_process_ptr (scheme_extension_table->scheme_current_process_ptr)
|
||||
#define scheme_fuel_counter_ptr (scheme_extension_table->scheme_fuel_counter_ptr)
|
||||
#endif
|
||||
#endif
|
||||
#ifndef NO_SCHEME_THREADS
|
||||
#define scheme_thread (scheme_extension_table->scheme_thread)
|
||||
#define scheme_thread_w_manager (scheme_extension_table->scheme_thread_w_manager)
|
||||
#define scheme_kill_thread (scheme_extension_table->scheme_kill_thread)
|
||||
#endif
|
||||
#define scheme_break_thread (scheme_extension_table->scheme_break_thread)
|
||||
#ifndef MZ_REAL_THREADS
|
||||
#define scheme_process_block (scheme_extension_table->scheme_process_block)
|
||||
#define scheme_swap_process (scheme_extension_table->scheme_swap_process)
|
||||
#else
|
||||
#define scheme_process_block_w_process (scheme_extension_table->scheme_process_block_w_process)
|
||||
#endif
|
||||
#define scheme_weak_suspend_thread (scheme_extension_table->scheme_weak_suspend_thread)
|
||||
#define scheme_weak_resume_thread (scheme_extension_table->scheme_weak_resume_thread)
|
||||
#define scheme_block_until (scheme_extension_table->scheme_block_until)
|
||||
#define scheme_in_main_thread (scheme_extension_table->scheme_in_main_thread)
|
||||
#define scheme_tls_allocate (scheme_extension_table->scheme_tls_allocate)
|
||||
#define scheme_tls_set (scheme_extension_table->scheme_tls_set)
|
||||
#define scheme_tls_get (scheme_extension_table->scheme_tls_get)
|
||||
#define scheme_make_manager (scheme_extension_table->scheme_make_manager)
|
||||
#define scheme_add_managed (scheme_extension_table->scheme_add_managed)
|
||||
#define scheme_remove_managed (scheme_extension_table->scheme_remove_managed)
|
||||
#define scheme_close_managed (scheme_extension_table->scheme_close_managed)
|
||||
#define scheme_signal_error (scheme_extension_table->scheme_signal_error)
|
||||
#define scheme_raise_exn (scheme_extension_table->scheme_raise_exn)
|
||||
#define scheme_warning (scheme_extension_table->scheme_warning)
|
||||
#define scheme_wrong_count (scheme_extension_table->scheme_wrong_count)
|
||||
#define scheme_case_lambda_wrong_count (scheme_extension_table->scheme_case_lambda_wrong_count)
|
||||
#define scheme_wrong_type (scheme_extension_table->scheme_wrong_type)
|
||||
#define scheme_arg_mismatch (scheme_extension_table->scheme_arg_mismatch)
|
||||
#define scheme_wrong_return_arity (scheme_extension_table->scheme_wrong_return_arity)
|
||||
#define scheme_unbound_global (scheme_extension_table->scheme_unbound_global)
|
||||
#define scheme_dynamic_wind (scheme_extension_table->scheme_dynamic_wind)
|
||||
#define scheme_make_type (scheme_extension_table->scheme_make_type)
|
||||
#define scheme_install_type_reader (scheme_extension_table->scheme_install_type_reader)
|
||||
#define scheme_install_type_writer (scheme_extension_table->scheme_install_type_writer)
|
||||
#define scheme_eof (scheme_extension_table->scheme_eof)
|
||||
#define scheme_null (scheme_extension_table->scheme_null)
|
||||
#define scheme_true (scheme_extension_table->scheme_true)
|
||||
#define scheme_false (scheme_extension_table->scheme_false)
|
||||
#define scheme_void (scheme_extension_table->scheme_void)
|
||||
#define scheme_undefined (scheme_extension_table->scheme_undefined)
|
||||
#define scheme_tail_call_waiting (scheme_extension_table->scheme_tail_call_waiting)
|
||||
#define scheme_multiple_values (scheme_extension_table->scheme_multiple_values)
|
||||
#define scheme_eval (scheme_extension_table->scheme_eval)
|
||||
#define scheme_eval_multi (scheme_extension_table->scheme_eval_multi)
|
||||
#define scheme_eval_compiled (scheme_extension_table->scheme_eval_compiled)
|
||||
#define scheme_eval_compiled_multi (scheme_extension_table->scheme_eval_compiled_multi)
|
||||
#define _scheme_eval_compiled (scheme_extension_table->_scheme_eval_compiled)
|
||||
#define _scheme_eval_compiled_multi (scheme_extension_table->_scheme_eval_compiled_multi)
|
||||
#ifndef MZ_REAL_THREADS
|
||||
#define scheme_apply (scheme_extension_table->scheme_apply)
|
||||
#define scheme_apply_multi (scheme_extension_table->scheme_apply_multi)
|
||||
#define scheme_apply_eb (scheme_extension_table->scheme_apply_eb)
|
||||
#define scheme_apply_multi_eb (scheme_extension_table->scheme_apply_multi_eb)
|
||||
#else
|
||||
#define scheme_apply_wp (scheme_extension_table->scheme_apply_wp)
|
||||
#define scheme_apply_multi_wp (scheme_extension_table->scheme_apply_multi_wp)
|
||||
#define scheme_apply_eb_wp (scheme_extension_table->scheme_apply_eb_wp)
|
||||
#define scheme_apply_multi_eb_wp (scheme_extension_table->scheme_apply_multi_eb_wp)
|
||||
#endif
|
||||
#define scheme_apply_to_list (scheme_extension_table->scheme_apply_to_list)
|
||||
#define scheme_eval_string (scheme_extension_table->scheme_eval_string)
|
||||
#define scheme_eval_string_multi (scheme_extension_table->scheme_eval_string_multi)
|
||||
#define scheme_eval_string_all (scheme_extension_table->scheme_eval_string_all)
|
||||
#define _scheme_apply_known_closed_prim (scheme_extension_table->_scheme_apply_known_closed_prim)
|
||||
#define _scheme_apply_known_closed_prim_multi (scheme_extension_table->_scheme_apply_known_closed_prim_multi)
|
||||
#define _scheme_apply_closed_prim (scheme_extension_table->_scheme_apply_closed_prim)
|
||||
#define _scheme_apply_closed_prim_multi (scheme_extension_table->_scheme_apply_closed_prim_multi)
|
||||
#define scheme_values (scheme_extension_table->scheme_values)
|
||||
#define scheme_check_one_value (scheme_extension_table->scheme_check_one_value)
|
||||
#define scheme_tail_apply (scheme_extension_table->scheme_tail_apply)
|
||||
#define scheme_tail_apply_no_copy (scheme_extension_table->scheme_tail_apply_no_copy)
|
||||
#define scheme_tail_apply_to_list (scheme_extension_table->scheme_tail_apply_to_list)
|
||||
#define scheme_tail_eval_expr (scheme_extension_table->scheme_tail_eval_expr)
|
||||
#define scheme_set_tail_buffer_size (scheme_extension_table->scheme_set_tail_buffer_size)
|
||||
#define scheme_force_value (scheme_extension_table->scheme_force_value)
|
||||
#define scheme_set_cont_mark (scheme_extension_table->scheme_set_cont_mark)
|
||||
#define scheme_push_continuation_frame (scheme_extension_table->scheme_push_continuation_frame)
|
||||
#define scheme_pop_continuation_frame (scheme_extension_table->scheme_pop_continuation_frame)
|
||||
#define scheme_temp_dec_mark_depth (scheme_extension_table->scheme_temp_dec_mark_depth)
|
||||
#define scheme_temp_inc_mark_depth (scheme_extension_table->scheme_temp_inc_mark_depth)
|
||||
#define scheme_current_continuation_marks (scheme_extension_table->scheme_current_continuation_marks)
|
||||
#ifndef MZ_REAL_THREADS
|
||||
#define scheme_do_eval (scheme_extension_table->scheme_do_eval)
|
||||
#else
|
||||
#define scheme_do_eval_w_process (scheme_extension_table->scheme_do_eval_w_process)
|
||||
#endif
|
||||
#ifndef SCHEME_NO_GC
|
||||
# ifndef SCHEME_NO_GC_PROTO
|
||||
#define GC_malloc (scheme_extension_table->GC_malloc)
|
||||
#define GC_malloc_atomic (scheme_extension_table->GC_malloc_atomic)
|
||||
# ifdef MZ_PRECISE_GC
|
||||
#define GC_malloc_one_tagged (scheme_extension_table->GC_malloc_one_tagged)
|
||||
#define GC_malloc_atomic_uncollectable (scheme_extension_table->GC_malloc_atomic_uncollectable)
|
||||
#define GC_malloc_array_tagged (scheme_extension_table->GC_malloc_array_tagged)
|
||||
# else
|
||||
#define GC_malloc_stubborn (scheme_extension_table->GC_malloc_stubborn)
|
||||
#define GC_malloc_uncollectable (scheme_extension_table->GC_malloc_uncollectable)
|
||||
# endif
|
||||
# endif
|
||||
#endif
|
||||
#define scheme_malloc_eternal (scheme_extension_table->scheme_malloc_eternal)
|
||||
#define scheme_end_stubborn_change (scheme_extension_table->scheme_end_stubborn_change)
|
||||
#define scheme_calloc (scheme_extension_table->scheme_calloc)
|
||||
#define scheme_strdup (scheme_extension_table->scheme_strdup)
|
||||
#define scheme_strdup_eternal (scheme_extension_table->scheme_strdup_eternal)
|
||||
#define scheme_malloc_fail_ok (scheme_extension_table->scheme_malloc_fail_ok)
|
||||
#define scheme_weak_reference (scheme_extension_table->scheme_weak_reference)
|
||||
#define scheme_weak_reference_indirect (scheme_extension_table->scheme_weak_reference_indirect)
|
||||
#define scheme_unweak_reference (scheme_extension_table->scheme_unweak_reference)
|
||||
#define scheme_add_finalizer (scheme_extension_table->scheme_add_finalizer)
|
||||
#define scheme_add_finalizer_once (scheme_extension_table->scheme_add_finalizer_once)
|
||||
#define scheme_add_scheme_finalizer (scheme_extension_table->scheme_add_scheme_finalizer)
|
||||
#define scheme_add_scheme_finalizer_once (scheme_extension_table->scheme_add_scheme_finalizer_once)
|
||||
#define scheme_register_finalizer (scheme_extension_table->scheme_register_finalizer)
|
||||
#define scheme_remove_all_finalization (scheme_extension_table->scheme_remove_all_finalization)
|
||||
#define scheme_dont_gc_ptr (scheme_extension_table->scheme_dont_gc_ptr)
|
||||
#define scheme_gc_ptr_ok (scheme_extension_table->scheme_gc_ptr_ok)
|
||||
#define scheme_collect_garbage (scheme_extension_table->scheme_collect_garbage)
|
||||
#define scheme_hash_table (scheme_extension_table->scheme_hash_table)
|
||||
#define scheme_add_to_table (scheme_extension_table->scheme_add_to_table)
|
||||
#define scheme_change_in_table (scheme_extension_table->scheme_change_in_table)
|
||||
#define scheme_lookup_in_table (scheme_extension_table->scheme_lookup_in_table)
|
||||
#define scheme_bucket_from_table (scheme_extension_table->scheme_bucket_from_table)
|
||||
#define scheme_make_prim (scheme_extension_table->scheme_make_prim)
|
||||
#define scheme_make_noneternal_prim (scheme_extension_table->scheme_make_noneternal_prim)
|
||||
#define scheme_make_closed_prim (scheme_extension_table->scheme_make_closed_prim)
|
||||
#define scheme_make_prim_w_arity (scheme_extension_table->scheme_make_prim_w_arity)
|
||||
#define scheme_make_folding_prim (scheme_extension_table->scheme_make_folding_prim)
|
||||
#define scheme_make_noneternal_prim_w_arity (scheme_extension_table->scheme_make_noneternal_prim_w_arity)
|
||||
#define scheme_make_closed_prim_w_arity (scheme_extension_table->scheme_make_closed_prim_w_arity)
|
||||
#define scheme_make_folding_closed_prim (scheme_extension_table->scheme_make_folding_closed_prim)
|
||||
#define scheme_make_closure (scheme_extension_table->scheme_make_closure)
|
||||
#define scheme_make_pair (scheme_extension_table->scheme_make_pair)
|
||||
#define scheme_make_string (scheme_extension_table->scheme_make_string)
|
||||
#define scheme_make_sized_string (scheme_extension_table->scheme_make_sized_string)
|
||||
#define scheme_make_sized_offset_string (scheme_extension_table->scheme_make_sized_offset_string)
|
||||
#define scheme_make_immutable_sized_string (scheme_extension_table->scheme_make_immutable_sized_string)
|
||||
#define scheme_make_string_without_copying (scheme_extension_table->scheme_make_string_without_copying)
|
||||
#define scheme_alloc_string (scheme_extension_table->scheme_alloc_string)
|
||||
#define scheme_append_string (scheme_extension_table->scheme_append_string)
|
||||
#define scheme_make_vector (scheme_extension_table->scheme_make_vector)
|
||||
#define scheme_make_integer_value (scheme_extension_table->scheme_make_integer_value)
|
||||
#define scheme_make_integer_value_from_unsigned (scheme_extension_table->scheme_make_integer_value_from_unsigned)
|
||||
#define scheme_make_double (scheme_extension_table->scheme_make_double)
|
||||
#ifdef MZ_USE_SINGLE_FLOATS
|
||||
#define scheme_make_float (scheme_extension_table->scheme_make_float)
|
||||
#endif
|
||||
#define scheme_make_char (scheme_extension_table->scheme_make_char)
|
||||
#define scheme_make_promise (scheme_extension_table->scheme_make_promise)
|
||||
#define scheme_make_promise_from_thunk (scheme_extension_table->scheme_make_promise_from_thunk)
|
||||
#ifndef NO_SCHEME_THREADS
|
||||
#define scheme_make_sema (scheme_extension_table->scheme_make_sema)
|
||||
#define scheme_post_sema (scheme_extension_table->scheme_post_sema)
|
||||
#define scheme_wait_sema (scheme_extension_table->scheme_wait_sema)
|
||||
#endif
|
||||
#define scheme_char_constants (scheme_extension_table->scheme_char_constants)
|
||||
#define scheme_get_int_val (scheme_extension_table->scheme_get_int_val)
|
||||
#define scheme_get_unsigned_int_val (scheme_extension_table->scheme_get_unsigned_int_val)
|
||||
#define scheme_real_to_double (scheme_extension_table->scheme_real_to_double)
|
||||
#define scheme_get_proc_name (scheme_extension_table->scheme_get_proc_name)
|
||||
#define scheme_make_bignum (scheme_extension_table->scheme_make_bignum)
|
||||
#define scheme_make_bignum_from_unsigned (scheme_extension_table->scheme_make_bignum_from_unsigned)
|
||||
#define scheme_bignum_to_double (scheme_extension_table->scheme_bignum_to_double)
|
||||
#define scheme_bignum_from_double (scheme_extension_table->scheme_bignum_from_double)
|
||||
#ifdef MZ_USE_SINGLE_FLOATS
|
||||
#define scheme_bignum_to_float (scheme_extension_table->scheme_bignum_to_float)
|
||||
#define scheme_bignum_from_float (scheme_extension_table->scheme_bignum_from_float)
|
||||
#else
|
||||
# define scheme_bignum_to_float scheme_bignum_to_double
|
||||
# define scheme_bignum_from_float scheme_bignum_from_double
|
||||
#endif
|
||||
#define scheme_bignum_to_string (scheme_extension_table->scheme_bignum_to_string)
|
||||
#define scheme_read_bignum (scheme_extension_table->scheme_read_bignum)
|
||||
#define scheme_bignum_normalize (scheme_extension_table->scheme_bignum_normalize)
|
||||
#define scheme_double_to_int (scheme_extension_table->scheme_double_to_int)
|
||||
#define scheme_make_rational (scheme_extension_table->scheme_make_rational)
|
||||
#define scheme_rational_to_double (scheme_extension_table->scheme_rational_to_double)
|
||||
#define scheme_rational_from_double (scheme_extension_table->scheme_rational_from_double)
|
||||
#ifdef MZ_USE_SINGLE_FLOATS
|
||||
#define scheme_rational_to_float (scheme_extension_table->scheme_rational_to_float)
|
||||
#define scheme_rational_from_float (scheme_extension_table->scheme_rational_from_float)
|
||||
#else
|
||||
# define scheme_rational_to_float scheme_rational_to_double
|
||||
# define scheme_rational_from_float scheme_rational_from_double
|
||||
#endif
|
||||
#define scheme_rational_normalize (scheme_extension_table->scheme_rational_normalize)
|
||||
#define scheme_rational_numerator (scheme_extension_table->scheme_rational_numerator)
|
||||
#define scheme_rational_denominator (scheme_extension_table->scheme_rational_denominator)
|
||||
#define scheme_make_complex (scheme_extension_table->scheme_make_complex)
|
||||
#define scheme_complex_normalize (scheme_extension_table->scheme_complex_normalize)
|
||||
#define scheme_complex_real_part (scheme_extension_table->scheme_complex_real_part)
|
||||
#define scheme_complex_imaginary_part (scheme_extension_table->scheme_complex_imaginary_part)
|
||||
#define scheme_is_exact (scheme_extension_table->scheme_is_exact)
|
||||
#define scheme_is_inexact (scheme_extension_table->scheme_is_inexact)
|
||||
#define scheme_expand (scheme_extension_table->scheme_expand)
|
||||
#define scheme_compile (scheme_extension_table->scheme_compile)
|
||||
#define scheme_make_promise_value (scheme_extension_table->scheme_make_promise_value)
|
||||
#define scheme_read (scheme_extension_table->scheme_read)
|
||||
#define scheme_write (scheme_extension_table->scheme_write)
|
||||
#define scheme_display (scheme_extension_table->scheme_display)
|
||||
#define scheme_write_w_max (scheme_extension_table->scheme_write_w_max)
|
||||
#define scheme_display_w_max (scheme_extension_table->scheme_display_w_max)
|
||||
#define scheme_write_string (scheme_extension_table->scheme_write_string)
|
||||
#define scheme_write_offset_string (scheme_extension_table->scheme_write_offset_string)
|
||||
#define scheme_write_to_string (scheme_extension_table->scheme_write_to_string)
|
||||
#define scheme_display_to_string (scheme_extension_table->scheme_display_to_string)
|
||||
#define scheme_write_to_string_w_max (scheme_extension_table->scheme_write_to_string_w_max)
|
||||
#define scheme_display_to_string_w_max (scheme_extension_table->scheme_display_to_string_w_max)
|
||||
#define scheme_debug_print (scheme_extension_table->scheme_debug_print)
|
||||
#define scheme_flush_output (scheme_extension_table->scheme_flush_output)
|
||||
#define scheme_format (scheme_extension_table->scheme_format)
|
||||
#define scheme_printf (scheme_extension_table->scheme_printf)
|
||||
#define scheme_getc (scheme_extension_table->scheme_getc)
|
||||
#define scheme_peekc (scheme_extension_table->scheme_peekc)
|
||||
#define scheme_ungetc (scheme_extension_table->scheme_ungetc)
|
||||
#define scheme_char_ready (scheme_extension_table->scheme_char_ready)
|
||||
#define scheme_peekc_is_ungetc (scheme_extension_table->scheme_peekc_is_ungetc)
|
||||
#define scheme_need_wakeup (scheme_extension_table->scheme_need_wakeup)
|
||||
#define scheme_get_chars (scheme_extension_table->scheme_get_chars)
|
||||
#define scheme_tell (scheme_extension_table->scheme_tell)
|
||||
#define scheme_output_tell (scheme_extension_table->scheme_output_tell)
|
||||
#define scheme_tell_line (scheme_extension_table->scheme_tell_line)
|
||||
#define scheme_count_lines (scheme_extension_table->scheme_count_lines)
|
||||
#define scheme_close_input_port (scheme_extension_table->scheme_close_input_port)
|
||||
#define scheme_close_output_port (scheme_extension_table->scheme_close_output_port)
|
||||
#define scheme_are_all_chars_ready (scheme_extension_table->scheme_are_all_chars_ready)
|
||||
#define scheme_make_port_type (scheme_extension_table->scheme_make_port_type)
|
||||
#define scheme_make_input_port (scheme_extension_table->scheme_make_input_port)
|
||||
#define scheme_make_output_port (scheme_extension_table->scheme_make_output_port)
|
||||
#define scheme_make_file_input_port (scheme_extension_table->scheme_make_file_input_port)
|
||||
#define scheme_make_named_file_input_port (scheme_extension_table->scheme_make_named_file_input_port)
|
||||
#define scheme_make_file_output_port (scheme_extension_table->scheme_make_file_output_port)
|
||||
#define scheme_make_string_input_port (scheme_extension_table->scheme_make_string_input_port)
|
||||
#define scheme_make_sized_string_input_port (scheme_extension_table->scheme_make_sized_string_input_port)
|
||||
#define scheme_make_string_output_port (scheme_extension_table->scheme_make_string_output_port)
|
||||
#define scheme_get_string_output (scheme_extension_table->scheme_get_string_output)
|
||||
#define scheme_get_sized_string_output (scheme_extension_table->scheme_get_sized_string_output)
|
||||
#define scheme_pipe (scheme_extension_table->scheme_pipe)
|
||||
#define scheme_file_exists (scheme_extension_table->scheme_file_exists)
|
||||
#define scheme_directory_exists (scheme_extension_table->scheme_directory_exists)
|
||||
#define scheme_expand_filename (scheme_extension_table->scheme_expand_filename)
|
||||
#define scheme_os_getcwd (scheme_extension_table->scheme_os_getcwd)
|
||||
#define scheme_os_setcwd (scheme_extension_table->scheme_os_setcwd)
|
||||
#define scheme_getdrive (scheme_extension_table->scheme_getdrive)
|
||||
#define scheme_split_pathname (scheme_extension_table->scheme_split_pathname)
|
||||
#define scheme_build_pathname (scheme_extension_table->scheme_build_pathname)
|
||||
#define scheme_alloc_fdset_array (scheme_extension_table->scheme_alloc_fdset_array)
|
||||
#define scheme_init_fdset_array (scheme_extension_table->scheme_init_fdset_array)
|
||||
#define scheme_get_fdset (scheme_extension_table->scheme_get_fdset)
|
||||
#define scheme_fdzero (scheme_extension_table->scheme_fdzero)
|
||||
#define scheme_fdset (scheme_extension_table->scheme_fdset)
|
||||
#define scheme_fdclr (scheme_extension_table->scheme_fdclr)
|
||||
#define scheme_fdisset (scheme_extension_table->scheme_fdisset)
|
||||
#define scheme_add_fd_handle (scheme_extension_table->scheme_add_fd_handle)
|
||||
#define scheme_add_fd_eventmask (scheme_extension_table->scheme_add_fd_eventmask)
|
||||
#define scheme_return_eof_for_error (scheme_extension_table->scheme_return_eof_for_error)
|
||||
#define scheme_make_namespace (scheme_extension_table->scheme_make_namespace)
|
||||
#define scheme_add_namespace_option (scheme_extension_table->scheme_add_namespace_option)
|
||||
#define scheme_add_global (scheme_extension_table->scheme_add_global)
|
||||
#define scheme_add_global_constant (scheme_extension_table->scheme_add_global_constant)
|
||||
#define scheme_add_global_keyword (scheme_extension_table->scheme_add_global_keyword)
|
||||
#define scheme_remove_global (scheme_extension_table->scheme_remove_global)
|
||||
#define scheme_remove_global_constant (scheme_extension_table->scheme_remove_global_constant)
|
||||
#define scheme_add_global_symbol (scheme_extension_table->scheme_add_global_symbol)
|
||||
#define scheme_remove_global_symbol (scheme_extension_table->scheme_remove_global_symbol)
|
||||
#define scheme_add_global_constant_symbol (scheme_extension_table->scheme_add_global_constant_symbol)
|
||||
#define scheme_set_keyword (scheme_extension_table->scheme_set_keyword)
|
||||
#define scheme_make_envunbox (scheme_extension_table->scheme_make_envunbox)
|
||||
#define scheme_lookup_global (scheme_extension_table->scheme_lookup_global)
|
||||
#define scheme_global_bucket (scheme_extension_table->scheme_global_bucket)
|
||||
#define scheme_set_global_bucket (scheme_extension_table->scheme_set_global_bucket)
|
||||
#define scheme_intern_symbol (scheme_extension_table->scheme_intern_symbol)
|
||||
#define scheme_intern_exact_symbol (scheme_extension_table->scheme_intern_exact_symbol)
|
||||
#define scheme_make_symbol (scheme_extension_table->scheme_make_symbol)
|
||||
#define scheme_make_exact_symbol (scheme_extension_table->scheme_make_exact_symbol)
|
||||
#define scheme_symbol_name (scheme_extension_table->scheme_symbol_name)
|
||||
#define scheme_symbol_name_and_size (scheme_extension_table->scheme_symbol_name_and_size)
|
||||
#define scheme_symbol_val (scheme_extension_table->scheme_symbol_val)
|
||||
#define scheme_make_struct_values (scheme_extension_table->scheme_make_struct_values)
|
||||
#define scheme_make_struct_names (scheme_extension_table->scheme_make_struct_names)
|
||||
#define scheme_make_struct_type (scheme_extension_table->scheme_make_struct_type)
|
||||
#define scheme_make_struct_instance (scheme_extension_table->scheme_make_struct_instance)
|
||||
#define scheme_is_struct_instance (scheme_extension_table->scheme_is_struct_instance)
|
||||
#define scheme_struct_ref (scheme_extension_table->scheme_struct_ref)
|
||||
#define scheme_struct_set (scheme_extension_table->scheme_struct_set)
|
||||
#ifndef NO_OBJECT_SYSTEM
|
||||
#define scheme_is_subclass (scheme_extension_table->scheme_is_subclass)
|
||||
#define scheme_is_implementation (scheme_extension_table->scheme_is_implementation)
|
||||
#define scheme_is_interface_extension (scheme_extension_table->scheme_is_interface_extension)
|
||||
#define scheme_is_a (scheme_extension_table->scheme_is_a)
|
||||
#define scheme_get_class_name (scheme_extension_table->scheme_get_class_name)
|
||||
#define scheme_get_interface_name (scheme_extension_table->scheme_get_interface_name)
|
||||
#define scheme_make_object (scheme_extension_table->scheme_make_object)
|
||||
#define scheme_make_uninited_object (scheme_extension_table->scheme_make_uninited_object)
|
||||
#define scheme_find_ivar (scheme_extension_table->scheme_find_ivar)
|
||||
#define scheme_make_class (scheme_extension_table->scheme_make_class)
|
||||
#define scheme_add_method (scheme_extension_table->scheme_add_method)
|
||||
#define scheme_add_method_w_arity (scheme_extension_table->scheme_add_method_w_arity)
|
||||
#define scheme_made_class (scheme_extension_table->scheme_made_class)
|
||||
#define scheme_class_to_interface (scheme_extension_table->scheme_class_to_interface)
|
||||
#define scheme_make_class_assembly (scheme_extension_table->scheme_make_class_assembly)
|
||||
#define scheme_create_class (scheme_extension_table->scheme_create_class)
|
||||
#define scheme_make_interface_assembly (scheme_extension_table->scheme_make_interface_assembly)
|
||||
#define scheme_create_interface (scheme_extension_table->scheme_create_interface)
|
||||
#define scheme_apply_generic_data (scheme_extension_table->scheme_apply_generic_data)
|
||||
#define scheme_get_generic_data (scheme_extension_table->scheme_get_generic_data)
|
||||
#endif
|
||||
#define scheme_invoke_unit (scheme_extension_table->scheme_invoke_unit)
|
||||
#define scheme_assemble_compound_unit (scheme_extension_table->scheme_assemble_compound_unit)
|
||||
#define scheme_make_compound_unit (scheme_extension_table->scheme_make_compound_unit)
|
||||
#define scheme_get_unit_name (scheme_extension_table->scheme_get_unit_name)
|
||||
#define scheme_eq (scheme_extension_table->scheme_eq)
|
||||
#define scheme_eqv (scheme_extension_table->scheme_eqv)
|
||||
#define scheme_equal (scheme_extension_table->scheme_equal)
|
||||
#define scheme_build_list (scheme_extension_table->scheme_build_list)
|
||||
#define scheme_list_length (scheme_extension_table->scheme_list_length)
|
||||
#define scheme_proper_list_length (scheme_extension_table->scheme_proper_list_length)
|
||||
#define scheme_alloc_list (scheme_extension_table->scheme_alloc_list)
|
||||
#define scheme_map_1 (scheme_extension_table->scheme_map_1)
|
||||
#define scheme_car (scheme_extension_table->scheme_car)
|
||||
#define scheme_cdr (scheme_extension_table->scheme_cdr)
|
||||
#define scheme_cadr (scheme_extension_table->scheme_cadr)
|
||||
#define scheme_caddr (scheme_extension_table->scheme_caddr)
|
||||
#define scheme_vector_to_list (scheme_extension_table->scheme_vector_to_list)
|
||||
#define scheme_list_to_vector (scheme_extension_table->scheme_list_to_vector)
|
||||
#define scheme_append (scheme_extension_table->scheme_append)
|
||||
#define scheme_box (scheme_extension_table->scheme_box)
|
||||
#define scheme_unbox (scheme_extension_table->scheme_unbox)
|
||||
#define scheme_set_box (scheme_extension_table->scheme_set_box)
|
||||
#define scheme_make_weak_box (scheme_extension_table->scheme_make_weak_box)
|
||||
#define scheme_load (scheme_extension_table->scheme_load)
|
||||
#define scheme_load_extension (scheme_extension_table->scheme_load_extension)
|
||||
#define scheme_register_extension_global (scheme_extension_table->scheme_register_extension_global)
|
||||
#define scheme_get_milliseconds (scheme_extension_table->scheme_get_milliseconds)
|
||||
#define scheme_get_process_milliseconds (scheme_extension_table->scheme_get_process_milliseconds)
|
||||
#define scheme_rep (scheme_extension_table->scheme_rep)
|
||||
#define scheme_banner (scheme_extension_table->scheme_banner)
|
||||
#define scheme_version (scheme_extension_table->scheme_version)
|
||||
#define scheme_check_proc_arity (scheme_extension_table->scheme_check_proc_arity)
|
||||
#define scheme_make_provided_string (scheme_extension_table->scheme_make_provided_string)
|
||||
#define scheme_make_args_string (scheme_extension_table->scheme_make_args_string)
|
||||
#define scheme_no_dumps (scheme_extension_table->scheme_no_dumps)
|
||||
#define scheme_system_library_subpath (scheme_extension_table->scheme_system_library_subpath)
|
||||
|
|
@ -1,170 +0,0 @@
|
|||
/* This file was generated by makeexn */
|
||||
#ifndef _MZEXN_DEFINES
|
||||
#define _MZEXN_DEFINES
|
||||
|
||||
enum {
|
||||
MZEXN,
|
||||
MZEXN_USER,
|
||||
MZEXN_VARIABLE,
|
||||
MZEXN_VARIABLE_KEYWORD,
|
||||
MZEXN_APPLICATION,
|
||||
MZEXN_APPLICATION_ARITY,
|
||||
MZEXN_APPLICATION_TYPE,
|
||||
MZEXN_APPLICATION_MISMATCH,
|
||||
MZEXN_APPLICATION_DIVIDE_BY_ZERO,
|
||||
MZEXN_APPLICATION_CONTINUATION,
|
||||
MZEXN_ELSE,
|
||||
MZEXN_STRUCT,
|
||||
MZEXN_OBJECT,
|
||||
MZEXN_UNIT,
|
||||
MZEXN_SYNTAX,
|
||||
MZEXN_READ,
|
||||
MZEXN_READ_EOF,
|
||||
MZEXN_I_O,
|
||||
MZEXN_I_O_PORT,
|
||||
MZEXN_I_O_PORT_READ,
|
||||
MZEXN_I_O_PORT_WRITE,
|
||||
MZEXN_I_O_PORT_CLOSED,
|
||||
MZEXN_I_O_PORT_USER,
|
||||
MZEXN_I_O_FILESYSTEM,
|
||||
MZEXN_I_O_TCP,
|
||||
MZEXN_THREAD,
|
||||
MZEXN_MISC,
|
||||
MZEXN_MISC_UNSUPPORTED,
|
||||
MZEXN_MISC_USER_BREAK,
|
||||
MZEXN_MISC_OUT_OF_MEMORY,
|
||||
MZEXN_OTHER
|
||||
};
|
||||
|
||||
#endif
|
||||
|
||||
#ifdef _MZEXN_TABLE
|
||||
|
||||
#define MZEXN_MAXARGS 4
|
||||
|
||||
#ifdef GLOBAL_EXN_ARRAY
|
||||
static exn_rec exn_table[] = {
|
||||
{ 2, NULL, NULL, 0 },
|
||||
{ 2, NULL, NULL, 0 },
|
||||
{ 3, NULL, NULL, 0 },
|
||||
{ 3, NULL, NULL, 0 },
|
||||
{ 3, NULL, NULL, 0 },
|
||||
{ 4, NULL, NULL, 0 },
|
||||
{ 4, NULL, NULL, 0 },
|
||||
{ 3, NULL, NULL, 0 },
|
||||
{ 3, NULL, NULL, 0 },
|
||||
{ 3, NULL, NULL, 0 },
|
||||
{ 2, NULL, NULL, 0 },
|
||||
{ 2, NULL, NULL, 0 },
|
||||
{ 2, NULL, NULL, 0 },
|
||||
{ 2, NULL, NULL, 0 },
|
||||
{ 3, NULL, NULL, 0 },
|
||||
{ 3, NULL, NULL, 0 },
|
||||
{ 3, NULL, NULL, 0 },
|
||||
{ 2, NULL, NULL, 0 },
|
||||
{ 3, NULL, NULL, 0 },
|
||||
{ 3, NULL, NULL, 0 },
|
||||
{ 3, NULL, NULL, 0 },
|
||||
{ 3, NULL, NULL, 0 },
|
||||
{ 3, NULL, NULL, 0 },
|
||||
{ 4, NULL, NULL, 0 },
|
||||
{ 2, NULL, NULL, 0 },
|
||||
{ 2, NULL, NULL, 0 },
|
||||
{ 2, NULL, NULL, 0 },
|
||||
{ 2, NULL, NULL, 0 },
|
||||
{ 3, NULL, NULL, 0 },
|
||||
{ 2, NULL, NULL, 0 }
|
||||
};
|
||||
#else
|
||||
static exn_rec *exn_table;
|
||||
#endif
|
||||
|
||||
#endif
|
||||
|
||||
#ifdef _MZEXN_PRESETUP
|
||||
|
||||
#ifndef GLOBAL_EXN_ARRAY
|
||||
exn_table = (exn_rec *)scheme_malloc(sizeof(exn_rec) * MZEXN_OTHER);
|
||||
exn_table[MZEXN].args = 2;
|
||||
exn_table[MZEXN_USER].args = 2;
|
||||
exn_table[MZEXN_VARIABLE].args = 3;
|
||||
exn_table[MZEXN_VARIABLE_KEYWORD].args = 3;
|
||||
exn_table[MZEXN_APPLICATION].args = 3;
|
||||
exn_table[MZEXN_APPLICATION_ARITY].args = 4;
|
||||
exn_table[MZEXN_APPLICATION_TYPE].args = 4;
|
||||
exn_table[MZEXN_APPLICATION_MISMATCH].args = 3;
|
||||
exn_table[MZEXN_APPLICATION_DIVIDE_BY_ZERO].args = 3;
|
||||
exn_table[MZEXN_APPLICATION_CONTINUATION].args = 3;
|
||||
exn_table[MZEXN_ELSE].args = 2;
|
||||
exn_table[MZEXN_STRUCT].args = 2;
|
||||
exn_table[MZEXN_OBJECT].args = 2;
|
||||
exn_table[MZEXN_UNIT].args = 2;
|
||||
exn_table[MZEXN_SYNTAX].args = 3;
|
||||
exn_table[MZEXN_READ].args = 3;
|
||||
exn_table[MZEXN_READ_EOF].args = 3;
|
||||
exn_table[MZEXN_I_O].args = 2;
|
||||
exn_table[MZEXN_I_O_PORT].args = 3;
|
||||
exn_table[MZEXN_I_O_PORT_READ].args = 3;
|
||||
exn_table[MZEXN_I_O_PORT_WRITE].args = 3;
|
||||
exn_table[MZEXN_I_O_PORT_CLOSED].args = 3;
|
||||
exn_table[MZEXN_I_O_PORT_USER].args = 3;
|
||||
exn_table[MZEXN_I_O_FILESYSTEM].args = 4;
|
||||
exn_table[MZEXN_I_O_TCP].args = 2;
|
||||
exn_table[MZEXN_THREAD].args = 2;
|
||||
exn_table[MZEXN_MISC].args = 2;
|
||||
exn_table[MZEXN_MISC_UNSUPPORTED].args = 2;
|
||||
exn_table[MZEXN_MISC_USER_BREAK].args = 3;
|
||||
exn_table[MZEXN_MISC_OUT_OF_MEMORY].args = 2;
|
||||
#endif
|
||||
|
||||
#endif
|
||||
|
||||
#ifdef _MZEXN_DECL_FIELDS
|
||||
|
||||
static const char *MZEXN_FIELDS[2] = { "message", "continuation-marks" };
|
||||
static const char *MZEXN_VARIABLE_FIELDS[1] = { "id" };
|
||||
static const char *MZEXN_APPLICATION_FIELDS[1] = { "value" };
|
||||
static const char *MZEXN_APPLICATION_ARITY_FIELDS[1] = { "expected" };
|
||||
static const char *MZEXN_APPLICATION_TYPE_FIELDS[1] = { "expected" };
|
||||
static const char *MZEXN_SYNTAX_FIELDS[1] = { "expr" };
|
||||
static const char *MZEXN_READ_FIELDS[1] = { "port" };
|
||||
static const char *MZEXN_I_O_PORT_FIELDS[1] = { "port" };
|
||||
static const char *MZEXN_I_O_FILESYSTEM_FIELDS[2] = { "pathname", "detail" };
|
||||
static const char *MZEXN_MISC_USER_BREAK_FIELDS[1] = { "continuation" };
|
||||
|
||||
#endif
|
||||
|
||||
#ifdef _MZEXN_SETUP
|
||||
|
||||
SETUP_STRUCT(MZEXN, NULL, "exn", 2, MZEXN_FIELDS)
|
||||
SETUP_STRUCT(MZEXN_USER, EXN_PARENT(MZEXN), "exn:user", 0, NULL)
|
||||
SETUP_STRUCT(MZEXN_VARIABLE, EXN_PARENT(MZEXN), "exn:variable", 1, MZEXN_VARIABLE_FIELDS)
|
||||
SETUP_STRUCT(MZEXN_VARIABLE_KEYWORD, EXN_PARENT(MZEXN_VARIABLE), "exn:variable:keyword", 0, NULL)
|
||||
SETUP_STRUCT(MZEXN_APPLICATION, EXN_PARENT(MZEXN), "exn:application", 1, MZEXN_APPLICATION_FIELDS)
|
||||
SETUP_STRUCT(MZEXN_APPLICATION_ARITY, EXN_PARENT(MZEXN_APPLICATION), "exn:application:arity", 1, MZEXN_APPLICATION_ARITY_FIELDS)
|
||||
SETUP_STRUCT(MZEXN_APPLICATION_TYPE, EXN_PARENT(MZEXN_APPLICATION), "exn:application:type", 1, MZEXN_APPLICATION_TYPE_FIELDS)
|
||||
SETUP_STRUCT(MZEXN_APPLICATION_MISMATCH, EXN_PARENT(MZEXN_APPLICATION), "exn:application:mismatch", 0, NULL)
|
||||
SETUP_STRUCT(MZEXN_APPLICATION_DIVIDE_BY_ZERO, EXN_PARENT(MZEXN_APPLICATION), "exn:application:divide-by-zero", 0, NULL)
|
||||
SETUP_STRUCT(MZEXN_APPLICATION_CONTINUATION, EXN_PARENT(MZEXN_APPLICATION), "exn:application:continuation", 0, NULL)
|
||||
SETUP_STRUCT(MZEXN_ELSE, EXN_PARENT(MZEXN), "exn:else", 0, NULL)
|
||||
SETUP_STRUCT(MZEXN_STRUCT, EXN_PARENT(MZEXN), "exn:struct", 0, NULL)
|
||||
SETUP_STRUCT(MZEXN_OBJECT, EXN_PARENT(MZEXN), "exn:object", 0, NULL)
|
||||
SETUP_STRUCT(MZEXN_UNIT, EXN_PARENT(MZEXN), "exn:unit", 0, NULL)
|
||||
SETUP_STRUCT(MZEXN_SYNTAX, EXN_PARENT(MZEXN), "exn:syntax", 1, MZEXN_SYNTAX_FIELDS)
|
||||
SETUP_STRUCT(MZEXN_READ, EXN_PARENT(MZEXN), "exn:read", 1, MZEXN_READ_FIELDS)
|
||||
SETUP_STRUCT(MZEXN_READ_EOF, EXN_PARENT(MZEXN_READ), "exn:read:eof", 0, NULL)
|
||||
SETUP_STRUCT(MZEXN_I_O, EXN_PARENT(MZEXN), "exn:i/o", 0, NULL)
|
||||
SETUP_STRUCT(MZEXN_I_O_PORT, EXN_PARENT(MZEXN_I_O), "exn:i/o:port", 1, MZEXN_I_O_PORT_FIELDS)
|
||||
SETUP_STRUCT(MZEXN_I_O_PORT_READ, EXN_PARENT(MZEXN_I_O_PORT), "exn:i/o:port:read", 0, NULL)
|
||||
SETUP_STRUCT(MZEXN_I_O_PORT_WRITE, EXN_PARENT(MZEXN_I_O_PORT), "exn:i/o:port:write", 0, NULL)
|
||||
SETUP_STRUCT(MZEXN_I_O_PORT_CLOSED, EXN_PARENT(MZEXN_I_O_PORT), "exn:i/o:port:closed", 0, NULL)
|
||||
SETUP_STRUCT(MZEXN_I_O_PORT_USER, EXN_PARENT(MZEXN_I_O_PORT), "exn:i/o:port:user", 0, NULL)
|
||||
SETUP_STRUCT(MZEXN_I_O_FILESYSTEM, EXN_PARENT(MZEXN_I_O), "exn:i/o:filesystem", 2, MZEXN_I_O_FILESYSTEM_FIELDS)
|
||||
SETUP_STRUCT(MZEXN_I_O_TCP, EXN_PARENT(MZEXN_I_O), "exn:i/o:tcp", 0, NULL)
|
||||
SETUP_STRUCT(MZEXN_THREAD, EXN_PARENT(MZEXN), "exn:thread", 0, NULL)
|
||||
SETUP_STRUCT(MZEXN_MISC, EXN_PARENT(MZEXN), "exn:misc", 0, NULL)
|
||||
SETUP_STRUCT(MZEXN_MISC_UNSUPPORTED, EXN_PARENT(MZEXN_MISC), "exn:misc:unsupported", 0, NULL)
|
||||
SETUP_STRUCT(MZEXN_MISC_USER_BREAK, EXN_PARENT(MZEXN_MISC), "exn:misc:user-break", 1, MZEXN_MISC_USER_BREAK_FIELDS)
|
||||
SETUP_STRUCT(MZEXN_MISC_OUT_OF_MEMORY, EXN_PARENT(MZEXN_MISC), "exn:misc:out-of-memory", 0, NULL)
|
||||
|
||||
#endif
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
|
||||
#ifdef MZSCHEME_SOMETHING_OMITTED
|
||||
# define SPECIAL_TAG "-special"
|
||||
#else
|
||||
# define SPECIAL_TAG ""
|
||||
#endif
|
||||
|
||||
#define VERSION "102/14" SPECIAL_TAG
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,184 +0,0 @@
|
|||
|
||||
enum {
|
||||
|
||||
/* compiled object types: (internal) */
|
||||
scheme_variable_type,
|
||||
scheme_local_type,
|
||||
scheme_local_unbox_type,
|
||||
scheme_syntax_type,
|
||||
scheme_application_type,
|
||||
scheme_sequence_type,
|
||||
scheme_branch_type,
|
||||
scheme_unclosed_procedure_type,
|
||||
scheme_let_value_type,
|
||||
scheme_let_void_type,
|
||||
scheme_letrec_type, /* 10 */
|
||||
scheme_let_one_type,
|
||||
scheme_with_cont_mark_type,
|
||||
|
||||
_scheme_values_types_, /* All following types are values */
|
||||
|
||||
/* intermediate compiled: */
|
||||
scheme_compiled_unclosed_procedure_type,
|
||||
scheme_compiled_let_value_type,
|
||||
scheme_compiled_let_void_type,
|
||||
scheme_compiled_syntax_type,
|
||||
|
||||
scheme_quote_compilation_type,
|
||||
|
||||
_scheme_compiled_values_types_,
|
||||
|
||||
/* procedure types */
|
||||
scheme_prim_type, /* 20 */
|
||||
scheme_closed_prim_type,
|
||||
scheme_linked_closure_type,
|
||||
scheme_case_closure_type,
|
||||
scheme_cont_type,
|
||||
scheme_escaping_cont_type,
|
||||
|
||||
/* basic types */
|
||||
scheme_char_type, /* 26 */
|
||||
scheme_integer_type,
|
||||
scheme_bignum_type,
|
||||
scheme_rational_type,
|
||||
scheme_float_type, /* 30 */
|
||||
scheme_double_type,
|
||||
scheme_complex_izi_type,
|
||||
scheme_complex_type,
|
||||
scheme_string_type,
|
||||
scheme_symbol_type,
|
||||
scheme_null_type,
|
||||
scheme_pair_type,
|
||||
scheme_vector_type,
|
||||
scheme_closure_type,
|
||||
scheme_input_port_type, /* 40 */
|
||||
scheme_output_port_type,
|
||||
scheme_eof_type,
|
||||
scheme_true_type,
|
||||
scheme_false_type,
|
||||
scheme_void_type,
|
||||
scheme_syntax_compiler_type,
|
||||
scheme_macro_type,
|
||||
scheme_promise_type,
|
||||
scheme_box_type,
|
||||
scheme_process_type, /* 50 */
|
||||
scheme_object_type,
|
||||
scheme_class_type,
|
||||
scheme_structure_type,
|
||||
scheme_generic_type,
|
||||
scheme_cont_mark_set_type,
|
||||
scheme_sema_type,
|
||||
scheme_hash_table_type,
|
||||
scheme_generic_data_type,
|
||||
scheme_weak_box_type,
|
||||
scheme_struct_type_type, /* 60 */
|
||||
scheme_id_macro_type,
|
||||
scheme_unit_type,
|
||||
scheme_exp_time_type,
|
||||
scheme_listener_type,
|
||||
scheme_namespace_type,
|
||||
scheme_config_type,
|
||||
scheme_reserved_1_type,
|
||||
scheme_will_executor_type,
|
||||
scheme_interface_type,
|
||||
scheme_manager_type, /* 70 */
|
||||
scheme_random_state_type,
|
||||
scheme_regexp_type,
|
||||
|
||||
/* These reserved types will let us add types
|
||||
without forcing recompilation of compiled MzScheme code */
|
||||
scheme_reserved_3_type,
|
||||
|
||||
/* more internal types: */
|
||||
scheme_compilation_top_type,
|
||||
|
||||
scheme_envunbox_type,
|
||||
scheme_eval_waiting_type,
|
||||
scheme_tail_call_waiting_type,
|
||||
scheme_class_data_type,
|
||||
scheme_undefined_type,
|
||||
scheme_struct_info_type, /* 80 */
|
||||
scheme_multiple_values_type,
|
||||
scheme_placeholder_type,
|
||||
scheme_case_lambda_sequence_type,
|
||||
scheme_begin0_sequence_type,
|
||||
|
||||
scheme_compiled_unit_type,
|
||||
scheme_unit_body_data_type,
|
||||
scheme_reserved_5_type,
|
||||
scheme_unit_compound_data_type,
|
||||
scheme_invoke_unit_data_type,
|
||||
|
||||
scheme_interface_data_type, /* 90 */
|
||||
|
||||
scheme_svector_type,
|
||||
|
||||
#ifdef MZTAG_REQUIRED
|
||||
_scheme_last_normal_type_,
|
||||
|
||||
scheme_rt_comp_env,
|
||||
scheme_rt_constant_binding,
|
||||
scheme_rt_link_info,
|
||||
scheme_rt_compile_info,
|
||||
scheme_rt_cont_mark,
|
||||
scheme_rt_saved_stack,
|
||||
scheme_rt_eval_in_env,
|
||||
scheme_rt_reply_item,
|
||||
scheme_rt_closure_info,
|
||||
scheme_rt_overflow,
|
||||
scheme_rt_dyn_wind_cell,
|
||||
scheme_rt_cont_mark_chain,
|
||||
scheme_rt_dyn_wind_info,
|
||||
scheme_rt_dyn_wind,
|
||||
scheme_rt_dup_check,
|
||||
scheme_rt_class_var,
|
||||
scheme_rt_class_method,
|
||||
scheme_rt_class_assembly,
|
||||
scheme_rt_init_obj_rec,
|
||||
scheme_rt_super_init_data,
|
||||
scheme_rt_thread_memory,
|
||||
scheme_rt_input_file,
|
||||
scheme_rt_input_fd,
|
||||
scheme_rt_oskit_console_input,
|
||||
scheme_rt_tested_input_file,
|
||||
scheme_rt_tested_output_file,
|
||||
scheme_rt_indexed_string,
|
||||
scheme_rt_output_file,
|
||||
scheme_rt_load_handler_data,
|
||||
scheme_rt_load_data,
|
||||
scheme_rt_pipe,
|
||||
scheme_rt_beos_process,
|
||||
scheme_rt_system_child,
|
||||
scheme_rt_tcp,
|
||||
scheme_rt_write_data,
|
||||
scheme_rt_tcp_select_info,
|
||||
scheme_rt_namespace_option,
|
||||
scheme_rt_param_data,
|
||||
scheme_rt_will,
|
||||
scheme_rt_will_registration,
|
||||
scheme_rt_breakable_wait,
|
||||
scheme_rt_sema_waiter,
|
||||
scheme_rt_struct_proc_info,
|
||||
scheme_rt_linker_name,
|
||||
scheme_rt_unit_id,
|
||||
scheme_rt_body_expr,
|
||||
scheme_rt_body_var,
|
||||
scheme_rt_param_map,
|
||||
scheme_rt_export_source,
|
||||
scheme_rt_unit_data_closure,
|
||||
scheme_rt_compound_linked_data,
|
||||
scheme_rt_do_invoke_data,
|
||||
scheme_rt_finalization,
|
||||
scheme_rt_finalizations,
|
||||
scheme_rt_cpp_object,
|
||||
scheme_rt_cpp_array_object,
|
||||
scheme_rt_stack_object,
|
||||
scheme_rt_preallocated_object,
|
||||
scheme_process_hop_type,
|
||||
scheme_rt_breakable,
|
||||
#endif
|
||||
|
||||
_scheme_last_type_
|
||||
};
|
||||
|
||||
extern char *scheme_get_type_name(Scheme_Type type);
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
|
||||
/* Standard settings for Unix platforms. */
|
||||
/* Used by sconfig.h for known architectures. */
|
||||
|
||||
#define SYSTEM_TYPE_NAME "unix"
|
||||
#define UNIX_FILE_SYSTEM
|
||||
|
||||
#define TIME_SYNTAX
|
||||
#define PROCESS_FUNCTION
|
||||
#define DIR_FUNCTION
|
||||
#define GETENV_FUNCTION
|
||||
|
||||
#define USE_FD_PORTS
|
||||
#define HAS_STANDARD_IOB
|
||||
#define FILES_HAVE_FDS
|
||||
#define USE_UNIX_SOCKETS_TCP
|
||||
|
||||
#define UNIX_PROCESSES
|
||||
#define CLOSE_ALL_FDS_AFTER_FORK
|
||||
|
||||
#define EXPAND_FILENAME_TILDE
|
||||
|
||||
#define DO_STACK_CHECK
|
||||
#define UNIX_FIND_STACK_BOUNDS
|
||||
#define STACK_SAFETY_MARGIN 50000
|
||||
|
||||
#define UNIX_DYNAMIC_LOAD
|
||||
|
||||
#define UNISTD_INCLUDE
|
||||
#define USE_FCHDIR
|
||||
|
||||
#define USE_GETRUSAGE
|
||||
|
|
@ -1,55 +0,0 @@
|
|||
/*
|
||||
MzScheme
|
||||
Copyright (c) 1995 Matthew Flatt
|
||||
All rights reserved.
|
||||
|
||||
Please see the full copyright in the documentation.
|
||||
|
||||
libscheme
|
||||
Copyright (c) 1994 Brent Benson
|
||||
All rights reserved.
|
||||
*/
|
||||
|
||||
/* This file should be linked with any MzScheme extension dynamic
|
||||
object. */
|
||||
|
||||
|
||||
#include "escheme.h"
|
||||
#ifdef INCLUDE_WITHOUT_PATHS
|
||||
# include "schvers.h"
|
||||
#else
|
||||
# include "../src/schvers.h"
|
||||
#endif
|
||||
|
||||
#ifdef MZ_PRECISE_GC
|
||||
# define PLAIN_OR_2K "@2k"
|
||||
#else
|
||||
# define PLAIN_OR_2K ""
|
||||
#endif
|
||||
|
||||
#ifdef LINK_EXTENSIONS_BY_TABLE
|
||||
Scheme_Extension_Table *scheme_extension_table;
|
||||
#endif
|
||||
|
||||
#ifdef CODEFRAGMENT_DYNAMIC_LOAD
|
||||
#pragma export on
|
||||
char *scheme_initialize_internal(
|
||||
#ifdef LINK_EXTENSIONS_BY_TABLE
|
||||
Scheme_Extension_Table *table
|
||||
#endif
|
||||
);
|
||||
#pragma export off
|
||||
#endif
|
||||
|
||||
char *scheme_initialize_internal(
|
||||
#ifdef LINK_EXTENSIONS_BY_TABLE
|
||||
Scheme_Extension_Table *table
|
||||
#endif
|
||||
)
|
||||
{
|
||||
#ifdef LINK_EXTENSIONS_BY_TABLE
|
||||
scheme_extension_table = table;
|
||||
#endif
|
||||
|
||||
return VERSION PLAIN_OR_2K;
|
||||
}
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
|
||||
(require-relative-library "base64s.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:base64^
|
||||
(require-relative-library "base64r.ss"))
|
||||
|
|
@ -1,68 +0,0 @@
|
|||
|
||||
(unit/sig mzlib:base64^
|
||||
(import)
|
||||
|
||||
(define (base64-encode src)
|
||||
; Always includes a terminator
|
||||
(let* ([len (string-length src)]
|
||||
[new-len (let ([l (add1 (ceiling (* len 8/6)))])
|
||||
; Break l into 72-character lines.
|
||||
; Insert CR/LF between each line.
|
||||
(+ l (* (quotient l 72) 2)))]
|
||||
[dest (make-string new-len #\0)]
|
||||
[char-map (list->vector
|
||||
(let ([each-char (lambda (s e)
|
||||
(let loop ([l null][i (char->integer e)])
|
||||
(if (= i (char->integer s))
|
||||
(cons s l)
|
||||
(loop (cons (integer->char i)
|
||||
l)
|
||||
(sub1 i)))))])
|
||||
(append
|
||||
(each-char #\A #\Z)
|
||||
(each-char #\a #\z)
|
||||
(each-char #\0 #\9)
|
||||
(list #\+ #\/))))])
|
||||
(let loop ([bits 0][v 0][col 0][srcp 0][destp 0])
|
||||
(cond
|
||||
[(= col 72)
|
||||
; Insert CRLF
|
||||
(string-set! dest destp #\return)
|
||||
(string-set! dest (add1 destp) #\linefeed)
|
||||
(loop bits
|
||||
v
|
||||
0
|
||||
srcp
|
||||
(+ destp 2))]
|
||||
[(and (= srcp len)
|
||||
(<= bits 6))
|
||||
; That's all, folks.
|
||||
; Write the last few bits.
|
||||
(begin
|
||||
(string-set! dest destp (vector-ref char-map (arithmetic-shift v (- 6 bits))))
|
||||
(add1 destp))
|
||||
(if (= col 71)
|
||||
; Have to write CRLF before terminator
|
||||
(begin
|
||||
(string-set! dest (+ destp 1) #\return)
|
||||
(string-set! dest (+ destp 2) #\linefeed)
|
||||
(string-set! dest (+ destp 3) #\=))
|
||||
(string-set! dest (add1 destp) #\=))
|
||||
dest]
|
||||
[(< bits 6)
|
||||
; Need more bits.
|
||||
(loop (+ bits 8)
|
||||
(bitwise-ior (arithmetic-shift v 8)
|
||||
(char->integer (string-ref src srcp)))
|
||||
col
|
||||
(add1 srcp)
|
||||
destp)]
|
||||
[else
|
||||
; Write a char.
|
||||
(string-set! dest destp (vector-ref char-map (arithmetic-shift v (- 6 bits))))
|
||||
(loop (- bits 6)
|
||||
(bitwise-and v (sub1 (arithmetic-shift 1 (- bits 6))))
|
||||
(add1 col)
|
||||
srcp
|
||||
(add1 destp))])))))
|
||||
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
|
||||
(define-signature mzlib:base64^
|
||||
(base64-encode))
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
|
||||
(require-library "cgiu.ss" "net")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:cgi^
|
||||
mzlib:cgi@)
|
||||
|
|
@ -1,313 +0,0 @@
|
|||
(unit/sig mzlib:cgi^
|
||||
(import)
|
||||
|
||||
;; type bindings = list ((symbol . string))
|
||||
|
||||
;; --------------------------------------------------------------------
|
||||
|
||||
;; Exceptions:
|
||||
|
||||
(define-struct cgi-error ())
|
||||
|
||||
;; chars : list (char)
|
||||
;; -- gives the suffix which is invalid, not including the `%'
|
||||
|
||||
(define-struct (incomplete-%-suffix struct:cgi-error) (chars))
|
||||
|
||||
;; char : char
|
||||
;; -- an invalid character in a hex string
|
||||
|
||||
(define-struct (invalid-%-suffix struct:cgi-error) (char))
|
||||
|
||||
;; --------------------------------------------------------------------
|
||||
|
||||
;; query-chars->string :
|
||||
;; list (char) -> string
|
||||
|
||||
;; -- The input is the characters post-processed as per Web specs, which
|
||||
;; is as follows:
|
||||
;; spaces are turned into "+"es and lots of things are turned into %XX,
|
||||
;; where XX are hex digits, eg, %E7 for ~. The output is a regular
|
||||
;; Scheme string with all the characters converted back.
|
||||
|
||||
(define query-chars->string
|
||||
(lambda (chars)
|
||||
(list->string
|
||||
(let loop ((chars chars))
|
||||
(if (null? chars) null
|
||||
(let ((first (car chars))
|
||||
(rest (cdr chars)))
|
||||
(let-values (((this rest)
|
||||
(cond
|
||||
((char=? first #\+)
|
||||
(values #\space rest))
|
||||
((char=? first #\%)
|
||||
(if (and (pair? rest)
|
||||
(pair? (cdr rest)))
|
||||
(values
|
||||
(integer->char
|
||||
(or (string->number
|
||||
(string
|
||||
(car rest) (cadr rest))
|
||||
16)
|
||||
(raise (make-invalid-%-suffix
|
||||
(if (string->number
|
||||
(string (car rest))
|
||||
16)
|
||||
(cadr rest)
|
||||
(car rest))))))
|
||||
(cddr rest))
|
||||
(raise
|
||||
(make-incomplete-%-suffix rest))))
|
||||
(else
|
||||
(values first rest)))))
|
||||
(cons this (loop rest)))))))))
|
||||
|
||||
;; string->html :
|
||||
;; string -> string
|
||||
;; -- the input is raw text, the output is HTML appropriately quoted
|
||||
|
||||
(define string->html
|
||||
(lambda (s)
|
||||
(apply string-append
|
||||
(map (lambda (c)
|
||||
(case c
|
||||
((#\<) "<")
|
||||
((#\>) ">")
|
||||
((#\&) "&")
|
||||
(else (string c))))
|
||||
(string->list s)))))
|
||||
|
||||
(define default-text-color "#000000")
|
||||
(define default-bg-color "#ffffff")
|
||||
(define default-link-color "#cc2200")
|
||||
(define default-vlink-color "#882200")
|
||||
(define default-alink-color "#444444")
|
||||
|
||||
;; generate-html-output :
|
||||
;; html-string x list (html-string) x ... -> ()
|
||||
|
||||
(define generate-html-output
|
||||
(opt-lambda (title body-lines
|
||||
(text-color default-text-color)
|
||||
(bg-color default-bg-color)
|
||||
(link-color default-link-color)
|
||||
(vlink-color default-vlink-color)
|
||||
(alink-color default-alink-color))
|
||||
(let ((sa string-append))
|
||||
(for-each
|
||||
(lambda (l)
|
||||
(display l) (newline))
|
||||
`("Content-type: text/html"
|
||||
""
|
||||
"<html>"
|
||||
"<!-- The form was processed, and this document was generated,"
|
||||
" using the CGI utilities for MzScheme. For more information"
|
||||
" on MzScheme, see"
|
||||
" http://www.cs.rice.edu/CS/PLT/packages/mzscheme/"
|
||||
" and for the CGI utilities, contact Shriram Krishnamurthi"
|
||||
" (shriram@cs.rice.edu). -->"
|
||||
|
||||
"<head>"
|
||||
,(sa "<title>" title "</title>")
|
||||
"</head>"
|
||||
""
|
||||
,(sa "<body bgcolor=\"" bg-color "\" text=\"" text-color "\"")
|
||||
,(sa " link=\"" link-color "\"")
|
||||
,(sa " vlink=\"" vlink-color "\" alink=\"" alink-color "\">")
|
||||
""
|
||||
,@body-lines
|
||||
""
|
||||
"</body>"
|
||||
"</html>")))))
|
||||
|
||||
;; read-until-char :
|
||||
;; iport x char -> list (char) x bool
|
||||
;; -- operates on the default input port; the second value indicates
|
||||
;; whether reading stopped because an EOF was hit (as opposed to the
|
||||
;; delimiter being seen); the delimiter is not part of the result
|
||||
|
||||
(define read-until-char
|
||||
(lambda (ip delimiter)
|
||||
(let loop ((chars '()))
|
||||
(let ((c (read-char ip)))
|
||||
(cond
|
||||
((eof-object? c)
|
||||
(values (reverse chars) #t))
|
||||
((char=? c delimiter)
|
||||
(values (reverse chars) #f))
|
||||
(else
|
||||
(loop (cons c chars))))))))
|
||||
|
||||
;; read-name+value :
|
||||
;; iport -> (symbol + bool) x (string + bool) x bool
|
||||
|
||||
;; -- If the first value is false, so is the second, and the third is
|
||||
;; true, indicating EOF was reached without any input seen. Otherwise,
|
||||
;; the first and second values contain strings and the third is either
|
||||
;; true or false depending on whether the EOF has been reached. The
|
||||
;; strings are processed to remove the CGI spec "escape"s.
|
||||
|
||||
;; This code is _slightly_ lax: it allows an input to end in `&'. It's
|
||||
;; not clear this is legal by the CGI spec, which suggests that the last
|
||||
;; value binding must end in an EOF. It doesn't look like this matters.
|
||||
;; It would also introduce needless modality and reduce flexibility.
|
||||
|
||||
(define read-name+value
|
||||
(lambda (ip)
|
||||
(let-values
|
||||
(((name eof?)
|
||||
(read-until-char ip #\=)))
|
||||
(cond
|
||||
((and eof? (null? name))
|
||||
(values #f #f #t))
|
||||
(eof?
|
||||
(generate-error-output
|
||||
(list "Server generated malformed input for POST method:"
|
||||
(string-append
|
||||
"No binding for `" (list->string name) "' field."))))
|
||||
(else
|
||||
(let-values (((value eof?)
|
||||
(read-until-char ip #\&)))
|
||||
(values (string->symbol (query-chars->string name))
|
||||
(query-chars->string value)
|
||||
eof?)))))))
|
||||
|
||||
;; get-bindings/post :
|
||||
;; () -> bindings
|
||||
|
||||
(define get-bindings/post
|
||||
(lambda ()
|
||||
(let-values (((name value eof?)
|
||||
(read-name+value
|
||||
(current-input-port))))
|
||||
(cond
|
||||
((and eof? (not name))
|
||||
null)
|
||||
((and eof? name)
|
||||
(list (cons name value)))
|
||||
(else
|
||||
(cons (cons name value)
|
||||
(get-bindings/post)))))))
|
||||
|
||||
;; get-bindings/get :
|
||||
;; () -> bindings
|
||||
|
||||
(define get-bindings/get
|
||||
(lambda ()
|
||||
(let ((p (open-input-string
|
||||
(getenv "QUERY_STRING"))))
|
||||
(let loop ()
|
||||
(let-values (((name value eof?)
|
||||
(read-name+value p)))
|
||||
(cond
|
||||
((and eof? (not name))
|
||||
null)
|
||||
((and eof? name)
|
||||
(list (cons name value)))
|
||||
(else
|
||||
(cons (cons name value)
|
||||
(loop)))))))))
|
||||
|
||||
;; get-bindings :
|
||||
;; () -> bindings
|
||||
|
||||
(define get-bindings
|
||||
(lambda ()
|
||||
(if (string=? (get-cgi-method) "POST")
|
||||
(get-bindings/post)
|
||||
(get-bindings/get))))
|
||||
|
||||
;; generate-error-output :
|
||||
;; list (html-string) -> <exit>
|
||||
|
||||
(define generate-error-output
|
||||
(lambda (error-message-lines)
|
||||
(generate-html-output "Internal Error"
|
||||
error-message-lines)
|
||||
(exit)))
|
||||
|
||||
;; bindings-as-html :
|
||||
;; bindings -> list (html-string)
|
||||
;; -- formats name-value bindings as HTML appropriate for displaying
|
||||
|
||||
(define bindings-as-html
|
||||
(lambda (bindings)
|
||||
`("<code>"
|
||||
,@(map
|
||||
(lambda (bind)
|
||||
(string-append
|
||||
(symbol->string (car bind))
|
||||
" --> "
|
||||
(cdr bind)
|
||||
"<br>"))
|
||||
bindings)
|
||||
"</code>")))
|
||||
|
||||
;; extract-bindings :
|
||||
;; (string + symbol) x bindings -> list (string)
|
||||
|
||||
;; -- Extracts the bindings associated with a given name. The semantics
|
||||
;; of forms states that a CHECKBOX may use the same NAME field multiple
|
||||
;; times. Hence, a list of strings is returned. Note that the result
|
||||
;; may be the empty list.
|
||||
|
||||
(define extract-bindings
|
||||
(lambda (field-name bindings)
|
||||
(let ((field-name (if (symbol? field-name) field-name
|
||||
(string->symbol field-name))))
|
||||
(let loop ((found null) (bindings bindings))
|
||||
(if (null? bindings)
|
||||
found
|
||||
(if (equal? field-name (caar bindings))
|
||||
(loop (cons (cdar bindings) found) (cdr bindings))
|
||||
(loop found (cdr bindings))))))))
|
||||
|
||||
;; extract-binding/single :
|
||||
;; (string + symbol) x bindings -> string
|
||||
;; -- used in cases where only one binding is supposed to occur
|
||||
|
||||
(define extract-binding/single
|
||||
(lambda (field-name bindings)
|
||||
(let ((field-name (if (symbol? field-name) field-name
|
||||
(string->symbol field-name))))
|
||||
(let ((result (extract-bindings field-name bindings)))
|
||||
(cond
|
||||
((null? result)
|
||||
(generate-error-output
|
||||
`(,(string-append "No binding for field `"
|
||||
(if (symbol? field-name)
|
||||
(symbol->string field-name)
|
||||
field-name)
|
||||
"' in <p>")
|
||||
,@(bindings-as-html bindings))))
|
||||
((null? (cdr result))
|
||||
(car result))
|
||||
(else
|
||||
(generate-error-output
|
||||
`(,(string-append "Multiple bindings for field `"
|
||||
(if (symbol? field-name)
|
||||
(symbol->string field-name)
|
||||
field-name)
|
||||
"' where only one was expected in <p>")
|
||||
,@(bindings-as-html bindings)))))))))
|
||||
|
||||
;; get-cgi-method :
|
||||
;; () -> string
|
||||
;; -- string is either GET or POST (though future extension is possible)
|
||||
|
||||
(define get-cgi-method
|
||||
(lambda ()
|
||||
(getenv "REQUEST_METHOD")))
|
||||
|
||||
;; generate-link-text :
|
||||
;; string x html-string -> html-string
|
||||
|
||||
(define generate-link-text
|
||||
(lambda (url anchor-text)
|
||||
(string-append "<a href=\"" url "\">" anchor-text "</a>")))
|
||||
|
||||
;; ====================================================================
|
||||
|
||||
|
||||
)
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
(require-library "macro.ss")
|
||||
|
||||
(define-signature mzlib:cgi^
|
||||
(
|
||||
;; -- exceptions raised --
|
||||
(struct cgi-error ())
|
||||
(struct incomplete-%-suffix (chars))
|
||||
(struct invalid-%-suffix (char))
|
||||
|
||||
;; -- cgi methods --
|
||||
get-bindings
|
||||
get-bindings/post
|
||||
get-bindings/get
|
||||
generate-html-output
|
||||
generate-error-output
|
||||
bindings-as-html
|
||||
extract-bindings
|
||||
extract-binding/single
|
||||
get-cgi-method
|
||||
|
||||
;; -- general HTML utilities --
|
||||
string->html
|
||||
generate-link-text
|
||||
))
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
(require-library "refer.ss")
|
||||
(require-library "cgis.ss" "net")
|
||||
|
||||
(define mzlib:cgi@ (require-library-unit/sig "cgir.ss" "net"))
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
|
||||
(require-relative-library "dnss.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:dns^
|
||||
(require-relative-library "dnsr.ss"))
|
||||
|
|
@ -1,293 +0,0 @@
|
|||
|
||||
(unit/sig mzlib:dns^
|
||||
(import)
|
||||
|
||||
(define types
|
||||
'((a 1)
|
||||
(ns 2)
|
||||
(md 3)
|
||||
(mf 4)
|
||||
(cname 5)
|
||||
(soa 6)
|
||||
(mb 7)
|
||||
(mg 8)
|
||||
(mr 9)
|
||||
(null 10)
|
||||
(wks 11)
|
||||
(ptr 12)
|
||||
(hinfo 13)
|
||||
(minfo 14)
|
||||
(mx 15)
|
||||
(txt 16)))
|
||||
|
||||
(define classes
|
||||
'((in 1)
|
||||
(cs 2)
|
||||
(ch 3)
|
||||
(hs 4)))
|
||||
|
||||
(define (cossa i l)
|
||||
(cond
|
||||
[(null? l) #f]
|
||||
[(equal? (cadar l) i)
|
||||
(car l)]
|
||||
[else (cossa i (cdr l))]))
|
||||
|
||||
|
||||
(define (number->octet-pair n)
|
||||
(list (integer->char (arithmetic-shift n -8))
|
||||
(integer->char (modulo n 256))))
|
||||
|
||||
(define (octet-pair->number a b)
|
||||
(+ (arithmetic-shift (char->integer a) 8)
|
||||
(char->integer b)))
|
||||
|
||||
(define (octet-quad->number a b c d)
|
||||
(+ (arithmetic-shift (char->integer a) 24)
|
||||
(arithmetic-shift (char->integer b) 16)
|
||||
(arithmetic-shift (char->integer c) 8)
|
||||
(char->integer d)))
|
||||
|
||||
(define (name->octets s)
|
||||
(let ([do-one (lambda (s)
|
||||
(cons
|
||||
(integer->char (string-length s))
|
||||
(string->list s)))])
|
||||
(let loop ([s s])
|
||||
(let ([m (regexp-match "^([^.]*)[.](.*)" s)])
|
||||
(if m
|
||||
(append
|
||||
(do-one (cadr m))
|
||||
(loop (caddr m)))
|
||||
(append
|
||||
(do-one s)
|
||||
(list #\nul)))))))
|
||||
|
||||
(define (make-std-query-header id question-count)
|
||||
(append
|
||||
(number->octet-pair id)
|
||||
(list #\001 #\nul) ; Opcode & flags (recusive flag set)
|
||||
(number->octet-pair question-count)
|
||||
(number->octet-pair 0)
|
||||
(number->octet-pair 0)
|
||||
(number->octet-pair 0)))
|
||||
|
||||
(define (make-query id name type class)
|
||||
(append
|
||||
(make-std-query-header id 1)
|
||||
(name->octets name)
|
||||
(number->octet-pair (cadr (assoc type types)))
|
||||
(number->octet-pair (cadr (assoc class classes)))))
|
||||
|
||||
(define (add-size-tag m)
|
||||
(append (number->octet-pair (length m)) m))
|
||||
|
||||
(define (rr-data rr)
|
||||
(cadddr (cdr rr)))
|
||||
|
||||
(define (rr-type rr)
|
||||
(cadr rr))
|
||||
|
||||
(define (rr-name rr)
|
||||
(car rr))
|
||||
|
||||
(define (parse-name start reply)
|
||||
(let ([v (char->integer (car start))])
|
||||
(cond
|
||||
[(zero? v)
|
||||
; End of name
|
||||
(values #f (cdr start))]
|
||||
[(zero? (bitwise-and #xc0 v))
|
||||
; Normal label
|
||||
(let loop ([len v][start (cdr start)][accum null])
|
||||
(cond
|
||||
[(zero? len)
|
||||
(let-values ([(s start) (parse-name start reply)])
|
||||
(let ([s0 (list->string (reverse! accum))])
|
||||
(values (if s
|
||||
(string-append s0 "." s)
|
||||
s0)
|
||||
start)))]
|
||||
[else (loop (sub1 len) (cdr start) (cons (car start) accum))]))]
|
||||
[else
|
||||
; Compression offset
|
||||
(let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8)
|
||||
(char->integer (cadr start)))])
|
||||
(let-values ([(s ignore-start) (parse-name (list-tail reply offset) reply)])
|
||||
(values s (cddr start))))])))
|
||||
|
||||
(define (parse-rr start reply)
|
||||
(let-values ([(name start) (parse-name start reply)])
|
||||
(let ([type (car (cossa (octet-pair->number (car start) (cadr start)) types))]
|
||||
[start (cddr start)])
|
||||
(let ([class (car (cossa (octet-pair->number (car start) (cadr start)) classes))]
|
||||
[start (cddr start)])
|
||||
(let ([ttl (octet-quad->number (car start) (cadr start)
|
||||
(caddr start) (cadddr start))]
|
||||
[start (cddddr start)])
|
||||
(let ([len (octet-pair->number (car start) (cadr start))]
|
||||
[start (cddr start)])
|
||||
; Extract next len bytes for data:
|
||||
(let loop ([len len][start start][accum null])
|
||||
(if (zero? len)
|
||||
(values (list name type class ttl (reverse! accum))
|
||||
start)
|
||||
(loop (sub1 len) (cdr start) (cons (car start) accum))))))))))
|
||||
|
||||
(define (parse-ques start reply)
|
||||
(let-values ([(name start) (parse-name start reply)])
|
||||
(let ([type (car (cossa (octet-pair->number (car start) (cadr start)) types))]
|
||||
[start (cddr start)])
|
||||
(let ([class (car (cossa (octet-pair->number (car start) (cadr start)) classes))]
|
||||
[start (cddr start)])
|
||||
(values (list name type class) start)))))
|
||||
|
||||
(define (parse-n parse start reply n)
|
||||
(let loop ([n n][start start][accum null])
|
||||
(if (zero? n)
|
||||
(values (reverse! accum) start)
|
||||
(let-values ([(rr start) (parse start reply)])
|
||||
(loop (sub1 n) start (cons rr accum))))))
|
||||
|
||||
(define (dns-query nameserver addr type class)
|
||||
(unless (assoc type types)
|
||||
(raise-type-error 'dns-query "DNS query type" type))
|
||||
(unless (assoc class classes)
|
||||
(raise-type-error 'dns-query "DNS query class" class))
|
||||
|
||||
(let* ([query (make-query (random 256) addr type class)]
|
||||
[reply
|
||||
(let-values ([(r w) (tcp-connect nameserver 53)])
|
||||
(dynamic-wind
|
||||
void
|
||||
|
||||
(lambda ()
|
||||
(display (list->string (add-size-tag query)) w)
|
||||
(flush-output w)
|
||||
|
||||
(let ([a (read-char r)]
|
||||
[b (read-char r)])
|
||||
(let ([len (octet-pair->number a b)])
|
||||
(let ([s (read-string len r)])
|
||||
(unless (= len (string-length s))
|
||||
(error 'dns-query "unexpected EOF from server"))
|
||||
(string->list s)))))
|
||||
|
||||
(lambda ()
|
||||
(close-input-port r)
|
||||
(close-output-port w))))])
|
||||
|
||||
; First two bytes must match sent message id:
|
||||
(unless (and (char=? (car reply) (car query))
|
||||
(char=? (cadr reply) (cadr query)))
|
||||
(error 'dns-query "bad reply id from server"))
|
||||
|
||||
(let ([v0 (caddr reply)]
|
||||
[v1 (cadddr reply)])
|
||||
; Check for error code:
|
||||
(let ([rcode (bitwise-and #xf (char->integer v1))])
|
||||
(unless (zero? rcode)
|
||||
(error 'dns-query "error from server: ~a"
|
||||
(case rcode
|
||||
[(1) "format error"]
|
||||
[(2) "server failure"]
|
||||
[(3) "name error"]
|
||||
[(4) "not implemented"]
|
||||
[(5) "refused"]))))
|
||||
|
||||
(let ([qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5))]
|
||||
[an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7))]
|
||||
[ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9))]
|
||||
[ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11))])
|
||||
|
||||
(let ([start (list-tail reply 12)])
|
||||
(let*-values ([(qds start) (parse-n parse-ques start reply qd-count)]
|
||||
[(ans start) (parse-n parse-rr start reply an-count)]
|
||||
[(nss start) (parse-n parse-rr start reply ns-count)]
|
||||
[(ars start) (parse-n parse-rr start reply ar-count)])
|
||||
(unless (null? start)
|
||||
(error 'dns-query "error parsing server reply"))
|
||||
(values (positive? (bitwise-and #x4 (char->integer v0)))
|
||||
qds ans nss ars reply)))))))
|
||||
|
||||
(define cache (make-hash-table))
|
||||
(define (dns-query/cache nameserver addr type class)
|
||||
(let ([key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class))])
|
||||
(let ([v (hash-table-get cache key (lambda () #f))])
|
||||
(if v
|
||||
(apply values v)
|
||||
(let-values ([(auth? qds ans nss ars reply) (dns-query nameserver addr type class)])
|
||||
(hash-table-put! cache key (list auth? qds ans nss ars reply))
|
||||
(values auth? qds ans nss ars reply))))))
|
||||
|
||||
(define (ip->string s)
|
||||
(format "~a.~a.~a.~a"
|
||||
(char->integer (list-ref s 0))
|
||||
(char->integer (list-ref s 1))
|
||||
(char->integer (list-ref s 2))
|
||||
(char->integer (list-ref s 3))))
|
||||
|
||||
(define (try-forwarding k nameserver)
|
||||
(let loop ([nameserver nameserver][tried (list nameserver)])
|
||||
; Normally the recusion is done for us, but it's technically optional
|
||||
(let-values ([(v ars auth?) (k nameserver)])
|
||||
(or v
|
||||
(and (not auth?)
|
||||
(let* ([ns (ormap
|
||||
(lambda (ar)
|
||||
(and (eq? (rr-type ar) 'a)
|
||||
(ip->string (rr-data ar))))
|
||||
ars)])
|
||||
(and ns
|
||||
(not (member ns tried))
|
||||
(loop ns (cons ns tried)))))))))
|
||||
|
||||
(define (dns-get-address nameserver addr)
|
||||
(or (try-forwarding
|
||||
(lambda (nameserver)
|
||||
(let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'a 'in)])
|
||||
(values (and (positive? (length ans))
|
||||
(let ([s (rr-data (car ans))])
|
||||
(ip->string s)))
|
||||
ars auth?)))
|
||||
nameserver)
|
||||
(error 'dns-get-address "bad address")))
|
||||
|
||||
(define (dns-get-mail-exchanger nameserver addr)
|
||||
(or (try-forwarding
|
||||
(lambda (nameserver)
|
||||
(let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'mx 'in)])
|
||||
(values (let loop ([ans ans][best-pref +inf.0][exchanger #f])
|
||||
(cond
|
||||
[(null? ans) (or exchanger
|
||||
;; Does 'soa mean that the input address is fine?
|
||||
(and (ormap
|
||||
(lambda (ns) (eq? (rr-type ns) 'soa))
|
||||
nss)
|
||||
addr))]
|
||||
[else
|
||||
(let ([d (rr-data (car ans))])
|
||||
(let ([pref (octet-pair->number (car d) (cadr d))])
|
||||
(if (< pref best-pref)
|
||||
(let-values ([(name start) (parse-name (cddr d) reply)])
|
||||
(loop (cdr ans) pref name))
|
||||
(loop (cdr ans) best-pref exchanger))))]))
|
||||
ars auth?)))
|
||||
nameserver)
|
||||
(error 'dns-get-mail-exchanger "bad address")))
|
||||
|
||||
(define (dns-find-nameserver)
|
||||
(case (system-type)
|
||||
[(unix) (with-handlers ([void (lambda (x) #f)])
|
||||
(with-input-from-file "/etc/resolv.conf"
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(let ([l (read-line)])
|
||||
(or (and (string? l)
|
||||
(let ([m (regexp-match
|
||||
(format "nameserver[ ~a]+([0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)" #\tab)
|
||||
l)])
|
||||
(and m (cadr m))))
|
||||
(and (not (eof-object? l))
|
||||
(loop))))))))]
|
||||
[else #f])))
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
|
||||
(define-signature mzlib:dns^
|
||||
(dns-get-address
|
||||
dns-get-mail-exchanger
|
||||
dns-find-nameserver))
|
||||
|
|
@ -1,999 +0,0 @@
|
|||
Time-stamp: <99/10/22 12:42:59 shriram>
|
||||
|
||||
The `net' collection contains libraries that provide access to the
|
||||
following _Internet_ (quasi-)protocols:
|
||||
|
||||
URL parsing
|
||||
CGI backends
|
||||
sendmail
|
||||
SMTP
|
||||
NNTP
|
||||
POP-3
|
||||
IMAP
|
||||
Mail header reading and writing
|
||||
DNS
|
||||
|
||||
Shriram Krishnamurthi
|
||||
shriram@cs.rice.edu
|
||||
Matthew Flatt
|
||||
mflatt@cs.utah.edu
|
||||
|
||||
==========================================================================
|
||||
_URL_ posting, _web clients_, _WWW_
|
||||
==========================================================================
|
||||
|
||||
Collection: net
|
||||
Files: _url.ss_, _urlr.ss_, _urls.ss_, _urlu.ss_
|
||||
|
||||
ABSTRACT -------------------------------------------------------------
|
||||
|
||||
The url package manages features of URLs.
|
||||
|
||||
TYPES ----------------------------------------------------------------
|
||||
|
||||
> url
|
||||
struct url (scheme host port path params query fragment)
|
||||
scheme : string or #f
|
||||
host : string or #f
|
||||
port : number or #f
|
||||
path : string
|
||||
params : string or #f
|
||||
query : string or #f
|
||||
fragment : string or #f
|
||||
|
||||
The basic structure for all URLs.
|
||||
|
||||
http://www.cs.rice.edu:80/cgi-bin/finger;xyz?name=shriram&host=nw#top
|
||||
1 2 3 4 5 6 7
|
||||
|
||||
1 = scheme, 2 = host, 3 = port, 4 = path,
|
||||
5 = params, 6 = query, 7 = fragment
|
||||
|
||||
> pure-port
|
||||
|
||||
A pure port is one from which the MIME headers have been removed, so
|
||||
that what remains is purely the first content fragment.
|
||||
|
||||
> mime-header
|
||||
struct mime-header (name value)
|
||||
name : string
|
||||
value : string
|
||||
|
||||
MIME header.
|
||||
|
||||
PROCEDURES -----------------------------------------------------------
|
||||
|
||||
> (unixpath->path string) -> path-string
|
||||
|
||||
Given a path from a URL structure, turns it into a path that
|
||||
conforms to the local OS path specifications. Useful for file
|
||||
accesses on the local disk system.
|
||||
|
||||
> (get-pure-port url [list-of-strings]) -> input-port
|
||||
|
||||
Takes a URL and returns a pure port corresponding to it. Writes the
|
||||
optional strings to the server.
|
||||
|
||||
> (get-impure-port url [list-of-strings]) -> input-port
|
||||
|
||||
Takes a URL and returns an impure port corresponding to it. Writes
|
||||
the optional strings to the server.
|
||||
|
||||
> (display-pure-port input-port) -> void
|
||||
|
||||
Writes the output of a pure port. For debugging purposes.
|
||||
|
||||
> (purify-port input-port) -> list-of-mime-headers
|
||||
|
||||
Purifies a port, returning the MIME headers.
|
||||
|
||||
> (string->url string) -> url
|
||||
|
||||
Turns a string into a URL.
|
||||
|
||||
> (netscape/string->url string) -> url
|
||||
|
||||
Turns a string into a URL, applying (what appear to be) Netscape's
|
||||
conventions on automatically specifying the scheme: a string
|
||||
starting with a slash gets the scheme "file", while all others get
|
||||
the scheme "http".
|
||||
|
||||
> (url->string url) -> string
|
||||
|
||||
Generates a string corresponding to the contents of the url struct.
|
||||
|
||||
> (call/input-url url url->port-proc port->void-proc [list-of-strings]) -> void
|
||||
|
||||
First argument is the URL to open. Second is a procedure that takes
|
||||
a URL and turns it into a (pure or impure) port. The third takes
|
||||
the (pure or impure) port and handles its contents. The optional
|
||||
fourth argument is a set of strings to send to the server.
|
||||
|
||||
> (combine-url/relative url string) -> url
|
||||
|
||||
Given a base URL and a relative path, combines the two and returns a
|
||||
new URL.
|
||||
|
||||
EXAMPLE --------------------------------------------------------------
|
||||
|
||||
(require-library "url.ss" "net")
|
||||
(define url:cs (string->url "http://www.cs.rice.edu/"))
|
||||
(define url:me (string->url "http://www.cs.rice.edu/~shriram/"))
|
||||
(define comb combine-url/relative)
|
||||
(define (test url)
|
||||
(call/input-url url get-pure-port display-pure-port))
|
||||
(test url:cs)
|
||||
|
||||
==========================================================================
|
||||
_CGI_ backends, _WWW_
|
||||
==========================================================================
|
||||
|
||||
Collection: net
|
||||
Libraries: _cgi.ss_, _cgic.ss_, _cgir.ss_, _cgis.ss_, _cgiu.ss_
|
||||
|
||||
ABSTRACT -------------------------------------------------------------
|
||||
|
||||
The cgi package helps programmers write scripts that follow the Common
|
||||
Gateway Interface (CGI) protocol of the World-Wide Web.
|
||||
|
||||
TYPES ----------------------------------------------------------------
|
||||
|
||||
binding:
|
||||
|
||||
A binding is an association of a form item with its value. Some form
|
||||
items (such as checkboxes) may correspond to multiple bindings. A
|
||||
binding is a tag-string pair, where a tag is a symbol or a string.
|
||||
|
||||
bindings:
|
||||
|
||||
A list of `binding's.
|
||||
|
||||
html-string:
|
||||
|
||||
A text string that has been escaped according to HTML conventions.
|
||||
|
||||
EXCEPTIONS -----------------------------------------------------------
|
||||
|
||||
> cgi-error
|
||||
struct cgi-error ()
|
||||
|
||||
cgi-error is a super-structure for all exceptions thrown by this
|
||||
library.
|
||||
|
||||
> incomplete-%-suffix
|
||||
struct (incomplete-%-suffix cgi-error) (chars)
|
||||
chars : list of chars
|
||||
|
||||
Used when a % in a query is followed by an incomplete suffix. The
|
||||
characters of the suffix -- excluding the "%" -- are provided by the
|
||||
exception.
|
||||
|
||||
> invalid-%-suffix
|
||||
struct (invalid-%-suffix cgi-error) (char)
|
||||
char : char
|
||||
|
||||
Used when the character immediately following a % in a query is
|
||||
invalid.
|
||||
|
||||
PROCEDURES -----------------------------------------------------------
|
||||
|
||||
> (get-bindings) -> bindings
|
||||
> (get-bindings/post) -> bindings
|
||||
> (get-bindings/get) -> bindings
|
||||
|
||||
Returns the bindings that corresponding to the options specified by
|
||||
the user. The /post and /get forms work only when POST and GET
|
||||
forms are used, respectively, while get-bindings determines the kind
|
||||
of form that was used and invokes the appropriate function.
|
||||
|
||||
> (extract-bindings symbol-or-string bindings) -> list of strings
|
||||
|
||||
Given a key and a set of bindings, extract-bindings determines which
|
||||
ones correspond to a given key. There may be zero, one, or many
|
||||
associations for a given key.
|
||||
|
||||
> (extract-binding/single symbol-or-string bindings) -> string
|
||||
|
||||
Given a key and a set of bindings, extract-binding/single ensures
|
||||
that the key has exactly one association, and returns it.
|
||||
|
||||
> (generate-html-output html-string list-of-html-strings [color color color color color]) -> void
|
||||
|
||||
The first argument is the title. The second is a list of strings
|
||||
that consist of the body. The last five arguments are each strings
|
||||
representing a HTML color; in order, they represent the color of the
|
||||
text, the background, un-visited links, visited links, and a link
|
||||
being selected.
|
||||
|
||||
> (string->html string) -> html-string
|
||||
|
||||
Converts a string into an html-string by applying the appropriate
|
||||
HTML quoting conventions.
|
||||
|
||||
> (generate-link-text string html-string) -> html-string
|
||||
|
||||
Takes a string representing a URL, a html-string for the anchor
|
||||
text, and generates HTML corresponding to an achor.
|
||||
|
||||
> (generate-error-output list-of-html-strings) -> <exit>
|
||||
|
||||
The procedure takes a series of strings representing the body,
|
||||
prints them with the subject line "Internal error", and forces the
|
||||
script to exit.
|
||||
|
||||
> (get-cgi-method) -> string
|
||||
|
||||
Returns either "GET" or "POST". Always returns a string when
|
||||
invoked inside a CGI script. Unpredictable otherwise.
|
||||
|
||||
> (bindings-as-html bindings) -> list of html-strings
|
||||
|
||||
Converts a set of bindings into a list of html-string's. Useful for
|
||||
debugging.
|
||||
|
||||
==========================================================================
|
||||
_sending mail_, _sendmail_
|
||||
==========================================================================
|
||||
|
||||
Collection: net
|
||||
Files: _mail.ss_, _mailr.ss_, _mails.ss_, _mailu.ss_
|
||||
|
||||
ABSTRACT -------------------------------------------------------------
|
||||
|
||||
The mail package helps programmers write programs that need to send
|
||||
electronic mail messages. The package assumes the existence of a
|
||||
conformant sendmail program on the local system; see also the SMTP
|
||||
package, below.
|
||||
|
||||
TYPES ----------------------------------------------------------------
|
||||
|
||||
All strings used in mail messages are assumed to conform to their
|
||||
corresponding SMTP specifications, except as noted otherwise.
|
||||
|
||||
EXCEPTIONS -----------------------------------------------------------
|
||||
|
||||
> no-mail-recipients
|
||||
struct (no-mail-recipients exn) ()
|
||||
|
||||
Raised when no mail recipients were specified.
|
||||
|
||||
PROCEDURES -----------------------------------------------------------
|
||||
|
||||
> (send-mail-message/port from-string subject-string to-list-of-strings cc-list-of-strings bcc-list-of-string) -> output-port
|
||||
|
||||
The first argument is the header for the sender, the second is the
|
||||
subject line, the third a list of To: recipients, the fourth a list
|
||||
of CC: recipients, and the fifth a list of BCC: recipients. The
|
||||
optional sixth argument is used for other mail headers, which must
|
||||
be specified completely formatted.
|
||||
|
||||
The return value is an output port into which the client must write
|
||||
the message. Clients are urged to use close-output-port on the
|
||||
return value as soon as the necessary text has been written, so that
|
||||
the sendmail process can complete.
|
||||
|
||||
The sender can hold any value, though of course spoofing should be
|
||||
used with care.
|
||||
|
||||
> (send-mail-message from-string subject-string to-list-of-strings cc-list-of-strings bcc-list-of-string body-list-of-strings [extra-headers-list-of-strings]) -> void
|
||||
|
||||
The arguments are the same as that for send-mail-message/port except
|
||||
that there is one extra input, the list of strings corresponding to
|
||||
the mail message (followed by the optional additional headers, if
|
||||
present). There is no interesting return value.
|
||||
|
||||
Lines that contain a single period do not need to be quoted.
|
||||
|
||||
==========================================================================
|
||||
_sending mail_, _SMTP_
|
||||
==========================================================================
|
||||
|
||||
Collection: net
|
||||
Files: _smtp.ss_, _smtpr.ss_, _smtps.ss_
|
||||
|
||||
ABSTRACT -------------------------------------------------------------
|
||||
|
||||
The SMTP package helps programmers write programs that need to send
|
||||
electronic mail messages using SMTP. The client must provide the
|
||||
address of an SMTP server; in contrast, the mail package (see above)
|
||||
uses a pre-configured sendmail on the local system.
|
||||
|
||||
TYPES ----------------------------------------------------------------
|
||||
|
||||
The head package defines the format of a `header' string, which is
|
||||
used by `send-smtp-message'. The head package also provides
|
||||
utilities to verify the formatting of a mail address. The procedures
|
||||
of the SMTP package assume that the given string arguments are
|
||||
well-formed.
|
||||
|
||||
EXCEPTIONS -----------------------------------------------------------
|
||||
|
||||
Communication errors are signalled via exn:user structure instances.
|
||||
|
||||
PROCEDURES -----------------------------------------------------------
|
||||
|
||||
> (smtp-send-message server-string from-string to-list-of-strings header message-list-of-strings [port]) -> void
|
||||
|
||||
The first argument is the IP address of the SMTP server. The
|
||||
`from-string' argument specifies the mail address of the sender, and
|
||||
`to-listof-strings' is a list of recipient addresses (including
|
||||
"To", "CC", and "BCC" recipients). The `header' argument is the
|
||||
complete message header, which should already include "From", "To",
|
||||
and "CC" fields consistent with the given sender and recipients.
|
||||
the `message-list-of-strings' argument is the body of the message,
|
||||
where each string in the list corresponds to a single line of
|
||||
message text; no string in `message-list-of-strings' should contain
|
||||
a carriage return or newline characters. The optional `port'
|
||||
argument specifies the IP port to use in contacting the SMTP server;
|
||||
the default is 25.
|
||||
|
||||
See the head package for utilities that construct a message headers
|
||||
and validate mail address strings.
|
||||
|
||||
> (smtp-sending-end-of-message [proc])
|
||||
|
||||
Parameter that detemines a send-done procedure to be called after
|
||||
`smtp-send-message' has completely sent the message. Before the
|
||||
send-done procedure is called, breaking the thread that is executing
|
||||
`smtp-send-message' cancels the send. After the send-done procedure
|
||||
is called, breaking may or may not cancel the send (and probably
|
||||
won't).
|
||||
|
||||
==========================================================================
|
||||
_NNTP_, _newsgroups_
|
||||
==========================================================================
|
||||
|
||||
Collection: net
|
||||
Files: _nntp.ss_, _nntpr.ss_, _nntps.ss_, _nntpu.ss_
|
||||
|
||||
ABSTRACT -------------------------------------------------------------
|
||||
|
||||
The nntp package helps programmers access Usenet groups via the NNTP
|
||||
protocols.
|
||||
|
||||
TYPES ----------------------------------------------------------------
|
||||
|
||||
> communicator
|
||||
struct communicator (sender receiver server port)
|
||||
sender : oport
|
||||
receiver : iport
|
||||
server : string
|
||||
port : number
|
||||
|
||||
Once a connection to a Usenet server has been established, its state
|
||||
is stored in a communicator, and other procedures take communicators
|
||||
as an argument.
|
||||
|
||||
> desired
|
||||
|
||||
A regular expression that matches against a Usenet header.
|
||||
|
||||
EXCEPTIONS -----------------------------------------------------------
|
||||
|
||||
> nntp
|
||||
struct (nntp exn) ()
|
||||
|
||||
The super-struct of all subsequent exceptions.
|
||||
|
||||
> unexpected-response
|
||||
struct (unexpected-response nntp) (code text)
|
||||
code : number
|
||||
text : string
|
||||
|
||||
Thrown whenever an unexpected response code is received. The text
|
||||
holds the response text sent by the server.
|
||||
|
||||
> bad-status-line
|
||||
struct (bad-status-line nntp) (line)
|
||||
line : string
|
||||
|
||||
Mal-formed status lines.
|
||||
|
||||
> premature-close
|
||||
struct (premature-close nntp) (communicator)
|
||||
communicator : communicator
|
||||
|
||||
Thrown when a remote server closes its connection unexpectedly.
|
||||
|
||||
> bad-newsgroup-line
|
||||
struct (bad-newsgroup-line nntp) (line)
|
||||
line : string
|
||||
|
||||
When the newsgroup line is improperly formatted.
|
||||
|
||||
> non-existent-group
|
||||
struct (non-existent-group nntp) (group)
|
||||
group : string
|
||||
|
||||
When the server does not recognize the name of the requested group.
|
||||
|
||||
> article-not-in-group
|
||||
struct (article-not-in-group nntp) (article)
|
||||
article : number
|
||||
|
||||
When an article is outside the server's range for that group.
|
||||
|
||||
> no-group-selected
|
||||
struct (no-group-selected nntp) ()
|
||||
|
||||
When an article operation is used before a group has been selected.
|
||||
|
||||
> article-not-found
|
||||
struct (article-not-found nntp) (article)
|
||||
article : number
|
||||
|
||||
When the server is unable to locate the article.
|
||||
|
||||
PROCEDURES -----------------------------------------------------------
|
||||
|
||||
> (connect-to-server server-string [port-number]) -> communicator
|
||||
|
||||
Connects to the name server. The second argument, if provided, must
|
||||
be a port number; otherwise the default NNTP port is used.
|
||||
|
||||
> (disconnect-from-server communicator) -> void
|
||||
|
||||
Disconnects a communicator.
|
||||
|
||||
> (open-news-group communicator newsgroup-string) -> three values: number number number
|
||||
|
||||
The second argument is the name of a newsgroup. The returned values
|
||||
are the total number of articles in that group, the first available
|
||||
article, and the last available article.
|
||||
|
||||
> (head-of-message communicator message-number) -> list of strings
|
||||
|
||||
Given a message number, returns its headers.
|
||||
|
||||
> (body-of-message communicator message-number) -> list of strings
|
||||
|
||||
Given a message number, returns the body of the message.
|
||||
|
||||
> (make-desired-header tag-string) -> desired
|
||||
|
||||
Takes the header's tag and returns a desired regexp for that header.
|
||||
|
||||
> (extract-desired-headers list-of-header-strings list-of-desireds) -> list of strings
|
||||
|
||||
Given a list of headers and of desired's, returns the header lines
|
||||
that match any of the desired's.
|
||||
|
||||
==========================================================================
|
||||
_POP-3_, _reading mail_
|
||||
==========================================================================
|
||||
|
||||
Collection: net
|
||||
Files: _pop3.ss_, _pop3r.ss_, _pop3s.ss_, _pop3u.ss_
|
||||
|
||||
Note: The pop3.ss invoke-opens the pop3r.ss unit with a "pop3:" prefix.
|
||||
|
||||
ABSTRACT -------------------------------------------------------------
|
||||
|
||||
Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose.
|
||||
http://www.cis.ohio-state.edu/htbin/rfc/rfc1939.html
|
||||
|
||||
TYPES ----------------------------------------------------------------
|
||||
|
||||
> communicator
|
||||
struct communicator (sender receiver server port state)
|
||||
sender : oport
|
||||
receiver : iport
|
||||
server : string
|
||||
port : number
|
||||
state : symbol = (disconnected, authorization, transaction)
|
||||
|
||||
Once a connection to a POP-3 server has been established, its state
|
||||
is stored in a communicator, and other procedures take communicators
|
||||
as an argument.
|
||||
|
||||
> desired
|
||||
|
||||
A regular expression that matches against a mail header.
|
||||
|
||||
EXCEPTIONS -----------------------------------------------------------
|
||||
|
||||
> pop3
|
||||
struct (pop3 exn) ()
|
||||
|
||||
The super-struct used for all other package exceptions.
|
||||
|
||||
> cannot-connect
|
||||
struct (cannot-connect pop3) ()
|
||||
|
||||
When a connection to a server cannot be established.
|
||||
|
||||
> username-rejected
|
||||
struct (username-rejected pop3) ()
|
||||
|
||||
If the username is rejected.
|
||||
|
||||
> password-rejected
|
||||
struct (password-rejected pop3) ()
|
||||
|
||||
If the password is rejected.
|
||||
|
||||
> not-ready-for-transaction
|
||||
struct (not-ready-for-transaction pop3) (communicator)
|
||||
communicator : communicator
|
||||
|
||||
When the communicator is not in transaction mode.
|
||||
|
||||
> not-given-headers
|
||||
struct (not-given-headers pop3) (communicator message)
|
||||
communicator : communicator
|
||||
message : number
|
||||
|
||||
When the server does not respond with headers for a message as
|
||||
requested.
|
||||
|
||||
> illegal-message-number
|
||||
struct (illegal-message-number pop3) (communicator message)
|
||||
communicator : communicator
|
||||
message : number
|
||||
|
||||
When the user specifies an illegal message number.
|
||||
|
||||
> cannot-delete-message
|
||||
struct (cannot-delete-message exn) (communicator message)
|
||||
communicator : communicator
|
||||
message : number
|
||||
|
||||
When the server is unable to delete a message.
|
||||
|
||||
> disconnect-not-quiet
|
||||
struct (disconnect-not-quiet pop3) (communicator)
|
||||
communicator : communicator
|
||||
|
||||
When the server does not gracefully disconnect.
|
||||
|
||||
> malformed-server-response
|
||||
struct (malformed-server-response pop3) (communicator)
|
||||
communicator : communicator
|
||||
|
||||
When the server produces a mal-formed response.
|
||||
|
||||
PROCEDURES -----------------------------------------------------------
|
||||
|
||||
> (connect-to-server server-string [port-number]) -> communicator
|
||||
|
||||
Connects to a server. Uses the default port number if none is
|
||||
provided.
|
||||
|
||||
> (disconnect-from-server communicator) -> void
|
||||
|
||||
Disconnects from as server. Sets the communicator state to
|
||||
disconnected.
|
||||
|
||||
> (authenticate/plain-text user-string passwd-string communicator) -> void
|
||||
|
||||
Takes a username and password string and, if successful, changes the
|
||||
communicator's state to transaction.
|
||||
|
||||
> (get-mailbox-status communicator) -> two values: count-number octet-number
|
||||
|
||||
Returns the number of messages and the number of octets.
|
||||
|
||||
> (get-message/complete communicator message-number) -> two lists of strings
|
||||
|
||||
Given a message number, returns a list of headers and list of
|
||||
strings for the body.
|
||||
|
||||
> (get-message/headers communicator message-number) -> list of strings
|
||||
|
||||
Given a message number, returns the list of headers.
|
||||
|
||||
> (get-message/body communicator message-number) -> list of strings
|
||||
|
||||
Given a message number, returns the list of strings for the body.
|
||||
|
||||
> (delete-message communicator message-number) -> void
|
||||
|
||||
Deletes the specified message.
|
||||
|
||||
> (get-unique-id/single communicator message-number) -> string
|
||||
|
||||
Gets the server's unique id for a particular message.
|
||||
|
||||
> (get-unique-id/all communicator) -> list of (cons message-number id-string)
|
||||
|
||||
Gets a list of unique id's from the server for all the messages in
|
||||
the mailbox.
|
||||
|
||||
> (make-desired-header tag-string) -> desired
|
||||
|
||||
Takes the header's tag and returns a desired regexp for that header.
|
||||
|
||||
> (extract-desired-headers list-of-strings list-of-desireds) -> list of strings
|
||||
|
||||
Given a list of headers and of desired's, returns the header lines
|
||||
that match any of the desired's.
|
||||
|
||||
EXAMPLE --------------------------------------------------------------
|
||||
|
||||
> (require-library "pop3.ss" "net")
|
||||
> (define c (pop3:connect-to-server "cs.rice.edu"))
|
||||
> (pop3:authenticate/plain-text "scheme" "********" c)
|
||||
> (pop3:get-mailbox-status c)
|
||||
196
|
||||
816400
|
||||
> (pop3:get-message/headers c 100)
|
||||
("Date: Thu, 6 Nov 1997 12:34:18 -0600 (CST)"
|
||||
"Message-Id: <199711061834.MAA11961@new-world.cs.rice.edu>"
|
||||
"From: Shriram Krishnamurthi <shriram@cs.rice.edu>"
|
||||
...
|
||||
"Status: RO")
|
||||
> (pop3:get-message/complete c 100)
|
||||
("Date: Thu, 6 Nov 1997 12:34:18 -0600 (CST)"
|
||||
"Message-Id: <199711061834.MAA11961@new-world.cs.rice.edu>"
|
||||
"From: Shriram Krishnamurthi <shriram@cs.rice.edu>"
|
||||
...
|
||||
"Status: RO")
|
||||
("some body" "text" "goes" "." "here" "." "")
|
||||
> (pop3:get-unique-id/single c 205)
|
||||
no message numbered 205 available for unique id
|
||||
> (list-tail (pop3:get-unique-id/all c) 194)
|
||||
((195 . "e24d13c7ef050000") (196 . "3ad2767070050000"))
|
||||
> (pop3:get-unique-id/single c 196)
|
||||
"3ad2767070050000"
|
||||
> (pop3:disconnect-from-server c)
|
||||
|
||||
==========================================================================
|
||||
_IMAP_, _reading mail_
|
||||
==========================================================================
|
||||
|
||||
Collection: net
|
||||
Files: _imap.ss_, _imapr.ss_, _imaps.ss_
|
||||
|
||||
ABSTRACT -------------------------------------------------------------
|
||||
|
||||
Implements portions of client-side RFC 2060, Internet Message Access
|
||||
Protocol - Version 4rev1, Crispin, http://www.isi.edu/in-notes/rfc2060.txt
|
||||
|
||||
TYPES ----------------------------------------------------------------
|
||||
|
||||
> imap
|
||||
|
||||
An opaque record reprsenting an IMAP connection.
|
||||
|
||||
> imap-flag
|
||||
|
||||
A symbol, but generally not a convenient one to use within a Scheme
|
||||
program. The `imap-flag->symbol' and `symbol->imap-flag' procedures
|
||||
convert IMAP flags to convenient symbols and vice-versa.
|
||||
|
||||
EXCEPTIONS -----------------------------------------------------------
|
||||
|
||||
Communication errors are signalled via exn:user structure instances.
|
||||
|
||||
PROCEDURES -----------------------------------------------------------
|
||||
|
||||
> (imap-connect server-string username-string password-string mailbox-string)
|
||||
-> three values: imap, message count, recent message count
|
||||
|
||||
Establishes an IMAP connection to the given server using the given
|
||||
username and password, and selects the specified mailbox. The second
|
||||
and third return values indicate the total number of message in the
|
||||
mailbox and the number of recent messages (i.e., messages received
|
||||
since the mailbox was last selected), respectively.
|
||||
|
||||
See also `imap-port-number', below.
|
||||
|
||||
A user's primary mailbox is always called "INBOX".
|
||||
|
||||
> (imap-disconnect imap) -> void
|
||||
|
||||
Closes an IMAP connection. The close may fail due to a communication
|
||||
error.
|
||||
|
||||
> (imap-force-disconnect imap) -> void
|
||||
|
||||
Closes an IMAP connection forcefully (i.e., without send a close
|
||||
message to the server). A forced disconnect never fails.
|
||||
|
||||
> (imap-reselect imap mailbox-string)
|
||||
-> two values: message count and recent message count
|
||||
|
||||
De-selects the mailbox currently selected by the connection and
|
||||
selects the specified mailbox, returning the total and recent
|
||||
message counts for the new mailbox.
|
||||
|
||||
This procedure is useful for polling a mailbox to see whether there
|
||||
are any new messages (by providing the currently selected mailbox as
|
||||
the new mailbox), but use imap-status with the 'uidnext flag to
|
||||
determine whether a mailbox has changed at all (e.g., via a copy
|
||||
instead of a move).
|
||||
|
||||
> (imap-status imap mailbox-string status-symbol-list)
|
||||
-> list of status values
|
||||
|
||||
Requests information about a mailbox from the server. The
|
||||
status-symbol-list specifies the request, and the return value
|
||||
includes one value for each symbol in status-symbol-list. The
|
||||
allowed status symbols are:
|
||||
'messages - number of messages
|
||||
'recent - number of recent messages
|
||||
'unseen - number of unseen messages
|
||||
'uidnext - uid for next received message
|
||||
'uidvalidity - id that changes when all uids are changed
|
||||
|
||||
> (imap-get-messages imap msg-num-list field-list)
|
||||
-> list of field-value lists
|
||||
|
||||
Downloads information for a set of messages. The `msg-num-list'
|
||||
argument specifies a set of messages by their message positions (not
|
||||
their uids). The `field-list' argument specifies the type of
|
||||
information to download for each message. The avilable fields are:
|
||||
|
||||
* 'uid - value is an integer
|
||||
* 'header - value is a header (string; see the head package)
|
||||
* 'body - value is a string (with CRLF-separated lines)
|
||||
* 'flags - value is a list of imap flags
|
||||
|
||||
The return value is a list of entry items in parallel to
|
||||
`msg-num-list'. Each entry is itself a list containing value items
|
||||
in parallel to `field-list'.
|
||||
|
||||
Example:
|
||||
(imap-get-message imap '(1 3 5) '(uid header))
|
||||
; => ((107 "From: larry@stooges.com ...")
|
||||
(110 "From: moe@stooges.com ...")
|
||||
(112 "From: curly@stooges.com ..."))
|
||||
|
||||
> (imap-flag->symbol imap-flag) -> symbol
|
||||
> (symbol->imap-flag symbol) -> imap-flag
|
||||
|
||||
An imap flag is a symbol, but it is generally not a convenient one
|
||||
to use within a Scheme program, because it usually starts with a
|
||||
backslash and flag comparisions are case-insensitive. The
|
||||
`imap-flag->symbol' and `symbol->imap-flag' procedures convert IMAP
|
||||
flags to convenient symbols and vice-versa:
|
||||
|
||||
symbol imap flag
|
||||
------ ----------
|
||||
'seen '|\Seen| \
|
||||
'answered '|\Answered| |
|
||||
'flagged '|\Flagged| > message flags
|
||||
'deleted '|\Deleted| |
|
||||
'draft '|\Draft| |
|
||||
'recent '|\Recent| /
|
||||
|
||||
'noinferiors '|\Noinferiors| \
|
||||
'noselect '|\Noselect| > mailbox flags
|
||||
'marked '|\Marked| |
|
||||
'unmarked '|\Unmarked| /
|
||||
|
||||
`imap-flag->symbol' and `symbol->imap-flag' act like the identity
|
||||
function when any other symbol/flag is provided.
|
||||
|
||||
> (imap-store imap mode msg-num-list imap-flags) -> void
|
||||
|
||||
Sets flags for a set of messages. The mode argument specifies how
|
||||
flags are set:
|
||||
|
||||
* '+ - add the given flags to each message
|
||||
* '- - remove the given flags from each emssage
|
||||
* '! - set each message's flags to the given set
|
||||
|
||||
The `msg-num-list' argument specifies a set of messages by their
|
||||
message positions (not their uids). The `flags' argument specifies
|
||||
the imap flags to add/remove/install.
|
||||
|
||||
Example:
|
||||
(imap-store imap '+ '(1 2 3) (list (symbol->imap-flag 'deleted)))
|
||||
; marks the first three messages to be deleted
|
||||
(imap-expunge imap)
|
||||
; permanently removes the first three messages (and possibly others)
|
||||
; from the currently-selected mailbox
|
||||
|
||||
> (imap-expunge imap) -> void
|
||||
|
||||
Purges every message currently marked with the '|\Deleted| flag from
|
||||
the mailbox.
|
||||
|
||||
> (imap-copy imap msg-num-list dest-mailbox-string) -> void
|
||||
|
||||
Copies the specified messages from the currently selected mailbox to
|
||||
the specified mailbox.
|
||||
|
||||
> (imap-mailbox-exists? imap mailbox-string) -> bool
|
||||
|
||||
Returns #t if the specified mailbox exists, #f otherwise.
|
||||
|
||||
> (imap-create-mailbox imap mailbox-string) -> void
|
||||
|
||||
Creates the specified mailbox. (It must not exist already.)
|
||||
|
||||
> (imap-list-child-mailboxes imap mailbox-string [delimiter-string])
|
||||
-> list of mailbox-info lists
|
||||
|
||||
Returns information about sub-mailboxes of the given mailbox. If
|
||||
mailbox-string is #f, information about all top-level mailboxes is
|
||||
returned. The optional `delimiter-string' is determined
|
||||
automatically (via `imap-get-hierarchy-delimiter') if it is not
|
||||
provided.
|
||||
|
||||
The return value is a list of mailbox-information lists. Each
|
||||
mailbox-information list contains two items:
|
||||
* a list of imap flags for the mailbox
|
||||
* the mailbox's name
|
||||
|
||||
> (imap-get-hierarchy-delimiter imap) -> string
|
||||
|
||||
Returns the server-specific string that is used as a separator in
|
||||
mailbox path names.
|
||||
|
||||
> (imap-port-number [k])
|
||||
|
||||
A parameter that determines the server port number. The initial
|
||||
value is 143.
|
||||
|
||||
==========================================================================
|
||||
_mail headers_
|
||||
==========================================================================
|
||||
|
||||
Collection: net
|
||||
Files: _head.ss_, _headr.ss_, _heads.ss_
|
||||
|
||||
ABSTRACT -------------------------------------------------------------
|
||||
|
||||
Implements utlities for RFC 822 headers and mail addresses.
|
||||
|
||||
TYPES ----------------------------------------------------------------
|
||||
|
||||
> header
|
||||
|
||||
A string that is an RFC-882-compliant header. A header string
|
||||
contains a series of CRLF-delimitted fields, and ends with two CRLFs
|
||||
(the first one terminates the last field, and the second terminates
|
||||
the header).
|
||||
|
||||
PROCEDURES -----------------------------------------------------------
|
||||
|
||||
> empty-header
|
||||
|
||||
A string correcponding to the empty header, useful for building up
|
||||
headers with `insert-field' and `append-headers'.
|
||||
|
||||
> (validate-header candidate-header-string) -> void
|
||||
|
||||
If the format of `candidate-header-string' matches RFC 822, void is
|
||||
returned, otherwise an exception is raised.
|
||||
|
||||
> (extract-field field-string header) -> string or #f
|
||||
|
||||
Returns the header content for the specified field, or #f if the
|
||||
field is not in the header. `field-string' should not end with ":",
|
||||
and it is used case-insensitively. The returned string will not
|
||||
contain the field name, color separator, of CRLF terminator for the
|
||||
field; however, if the field spans multiple lines, the CRLFs
|
||||
separating the lines will be intact.
|
||||
|
||||
Example:
|
||||
(extract-field "TO" (insert-field "to" "me@localhost" empty-header))
|
||||
; => "me@localhost"
|
||||
|
||||
> (remove-field field-string header) -> header
|
||||
|
||||
Creates a new header by removing the specified field from `header'
|
||||
(or the first instance of the field, if it occurs multiple
|
||||
times). If the field is not in `header', then the return value is
|
||||
`header'.
|
||||
|
||||
> (insert-field field-string value-string header) -> header
|
||||
|
||||
Creates a new header by prefixing the given header with the given
|
||||
field-value pair. `value-string' should not contain a terminating
|
||||
CRLF, but a multi-line value (perhaps created with
|
||||
`data-lines->data') may contain seperator CRLFs.
|
||||
|
||||
> (append-headers a-header another-header) -> header
|
||||
|
||||
> (standard-message-header from-string to-list-of-strings cc-list-of-strings bcc-list-of-strings subject-string) -> header
|
||||
|
||||
Creates a standard mail header given the sender, various lists of
|
||||
recipients, and a subject. (The BCC recipients do not acually appear
|
||||
in the header, but they're accepted anyway to complete the
|
||||
abstarction.)
|
||||
|
||||
> (data-lines->data list-of-strings) -> string
|
||||
|
||||
Merges multiple lines for a single field value into one string,
|
||||
adding CRLF-TAB separators.
|
||||
|
||||
> (extract-addresses string kind) -> list of strings or
|
||||
list of list of strings
|
||||
|
||||
Parses `string' as a list of comma-delimited mail addresses, raising
|
||||
an exception if the list is ill-formed. This procedure can be used
|
||||
for single-address strings, in which case the returned list should
|
||||
contain only one address.
|
||||
|
||||
The `kind' argument specifies which portion of an address should be
|
||||
returned:
|
||||
|
||||
* 'name - the free-form name in the address, or the address
|
||||
itself if no name is available:
|
||||
"John Doe <doe@localhost>" => "Jon Doe"
|
||||
"doe@localhost (Johnny Doe)" => "Johnny Doe"
|
||||
"doe@localhost" => "doe@localhost"
|
||||
|
||||
* 'address - just the mailing address, without any free-form
|
||||
names:
|
||||
"Jon Doe <doe@localhost>" => "doe@localhost"
|
||||
"doe@localhost (Johnny Doe)" => "doe@localhost"
|
||||
"doe@localhost" => "doe@localhost"
|
||||
|
||||
* 'full - the full address, essentially as it appears in the
|
||||
input, but normalized:
|
||||
"Jon Doe < doe@localhost >" => "Jon Doe <doe@localhost>"
|
||||
" doe@localhost (Johnny Doe)" => "doe@localhost (Johnny Doe)"
|
||||
"doe@localhost" => "doe@localhost"
|
||||
|
||||
* 'all - a list containing each of the three posibilities:
|
||||
free-form name, address, and full address (in that
|
||||
order)
|
||||
|
||||
Example:
|
||||
(extract-addresses " \"Doe, John\" <doe@localhost>, john" 'address)
|
||||
; => ("doe@localhost" "john")
|
||||
|
||||
> (assemble-address-field list-of-address-strings) -> string
|
||||
|
||||
Creates a header field value from a list of addresses. The addresses
|
||||
are comma-separated, and possibly broken into multiple lines.
|
||||
|
||||
==========================================================================
|
||||
_DNS_, _domain name service_
|
||||
==========================================================================
|
||||
|
||||
Collection: net
|
||||
Files: _dns.ss_, _dnsr.ss_, _dnss.ss_
|
||||
|
||||
ABSTRACT -------------------------------------------------------------
|
||||
|
||||
Implements a DNS client, based on RFC 1035
|
||||
|
||||
PROCEDURES -----------------------------------------------------------
|
||||
|
||||
> (dns-get-address nameserver-string address-string) -> address-string
|
||||
|
||||
Consults the specified nameserver (normally a numerical address like
|
||||
"128.42.1.30") to obtain a numerical address for the given internet
|
||||
address.
|
||||
|
||||
The query record sent to the DNS server includes the "recursive"
|
||||
bit, but `dns-get-address' also implements a recursive search itself
|
||||
in case the server does not provide this optional feature.
|
||||
|
||||
> (dns-get-mail-exchanger nameserver-string address-string) -> address-string
|
||||
|
||||
Consults the specified nameserver to obtain the address for a mail
|
||||
exchanger the given mail host address. For example, the mail
|
||||
exchanger for "ollie.cs.rice.edu" is currently "cs.rice.edu".
|
||||
|
||||
> (dns-find-nameserver) -> address-string or #f
|
||||
|
||||
Attempts to find the address of a nameserver on the present system.
|
||||
Under Unix, this procedure parses /etc/resolv.conf to extract the
|
||||
first nameserver address.
|
||||
|
||||
==========================================================================
|
||||
_Base 64 Encoding_, _base64_
|
||||
==========================================================================
|
||||
|
||||
Collection: net
|
||||
Files: _base64.ss_, _base64r.ss_, _base64s.ss_
|
||||
|
||||
ABSTRACT -------------------------------------------------------------
|
||||
|
||||
Implements a Base 64 (mime-standard) encoder. (We'll implement a
|
||||
decoder eventually.)
|
||||
|
||||
PROCEDURES -----------------------------------------------------------
|
||||
|
||||
> (base64-encode string) -> string
|
||||
|
||||
Consumes a string and returns its base64 encoding as a new string.
|
||||
The returned string is broken into 72-character lines separated by
|
||||
CRLF combinations, and it always ends with the "=" base64
|
||||
terminator.
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
|
||||
(require-relative-library "heads.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:head^
|
||||
(require-relative-library "headr.ss"))
|
||||
|
|
@ -1,243 +0,0 @@
|
|||
|
||||
(unit/sig mzlib:head^
|
||||
(import)
|
||||
|
||||
(define empty-header (string #\return #\newline))
|
||||
|
||||
(define (string->ci-regexp s)
|
||||
(list->string
|
||||
(apply
|
||||
append
|
||||
(map
|
||||
(lambda (c)
|
||||
(cond
|
||||
[(memq c '(#\$ #\| #\\ #\[ #\] #\. #\* #\? #\+ #\( #\) #\^))
|
||||
(list #\\ c)]
|
||||
[(char-alphabetic? c)
|
||||
(list #\[ (char-upcase c) (char-downcase c) #\])]
|
||||
[else (list c)]))
|
||||
(string->list s)))))
|
||||
|
||||
(define re:field-start (regexp
|
||||
(format "^[^~a~a~a~a~a:~a-~a]*:"
|
||||
#\space #\tab #\linefeed #\return #\vtab
|
||||
(integer->char 1)
|
||||
(integer->char 26))))
|
||||
(define re:continue (regexp (format "^[~a~a~a]" #\space #\tab #\vtab)))
|
||||
|
||||
(define (validate-header s)
|
||||
(let ([len (string-length s)])
|
||||
(let loop ([offset 0])
|
||||
(cond
|
||||
[(and (= (+ offset 2) len)
|
||||
(string=? empty-header (substring s offset len)))
|
||||
(void)] ; validated
|
||||
[(= offset len) (error 'validate-header "missing ending CRLF")]
|
||||
[(or (regexp-match re:field-start s offset)
|
||||
(regexp-match re:continue s offset))
|
||||
(let ([m (regexp-match-positions (string #\return #\linefeed) s offset)])
|
||||
(if m
|
||||
(loop (cdar m))
|
||||
(error 'validate-header "missing ending CRLF")))]
|
||||
[else (error 'validate-header "ill-formed header at ~s"
|
||||
(substring s offset (string-length s)))]))))
|
||||
|
||||
(define (make-field-start-regexp field)
|
||||
(format "(^|[~a][~a])(~a: *)"
|
||||
#\return #\linefeed
|
||||
(string->ci-regexp field)))
|
||||
|
||||
(define (extract-field field header)
|
||||
(let ([m (regexp-match-positions
|
||||
(make-field-start-regexp field)
|
||||
header)])
|
||||
(and m
|
||||
(let ([s (substring header
|
||||
(cdaddr m)
|
||||
(string-length header))])
|
||||
(let ([m (regexp-match-positions
|
||||
(format "[~a][~a][^: ~a~a]*:"
|
||||
#\return #\linefeed
|
||||
#\return #\linefeed)
|
||||
s)])
|
||||
(if m
|
||||
(substring s 0 (caar m))
|
||||
; Rest of header is this field, but strip trailing CRLFCRLF:
|
||||
(regexp-replace (format "~a~a~a~a$" #\return #\linefeed #\return #\linefeed)
|
||||
s
|
||||
"")))))))
|
||||
|
||||
(define (remove-field field header)
|
||||
(let ([m (regexp-match-positions
|
||||
(make-field-start-regexp field)
|
||||
header)])
|
||||
(if m
|
||||
(let ([pre (substring header
|
||||
0
|
||||
(caaddr m))]
|
||||
[s (substring header
|
||||
(cdaddr m)
|
||||
(string-length header))])
|
||||
(let ([m (regexp-match-positions
|
||||
(format "[~a][~a][^: ~a~a]*:"
|
||||
#\return #\linefeed
|
||||
#\return #\linefeed)
|
||||
s)])
|
||||
(if m
|
||||
(string-append pre (substring s (+ 2 (caar m))
|
||||
(string-length s)))
|
||||
pre)))
|
||||
header)))
|
||||
|
||||
(define (insert-field field data header)
|
||||
(let ([field (format "~a: ~a~a~a"
|
||||
field
|
||||
data
|
||||
#\return #\linefeed)])
|
||||
(string-append field header)))
|
||||
|
||||
(define (append-headers a b)
|
||||
(let ([alen (string-length a)])
|
||||
(if (> alen 1)
|
||||
(string-append (substring a 0 (- alen 2)) b)
|
||||
(error 'append-headers "first argument is not a header: ~a" a))))
|
||||
|
||||
(define (standard-message-header from tos ccs bccs subject)
|
||||
(let ([h (insert-field
|
||||
"Subject" subject
|
||||
empty-header)])
|
||||
; NOTE: bccs don't go into the header; that's why
|
||||
; they're "blind"
|
||||
(let ([h (if (null? ccs)
|
||||
h
|
||||
(insert-field
|
||||
"CC" (assemble-address-field ccs)
|
||||
h))])
|
||||
(let ([h (if (null? tos)
|
||||
h
|
||||
(insert-field
|
||||
"To" (assemble-address-field tos)
|
||||
h))])
|
||||
(insert-field
|
||||
"From" from
|
||||
h)))))
|
||||
|
||||
(define (splice l sep)
|
||||
(if (null? l)
|
||||
""
|
||||
(format "~a~a"
|
||||
(car l)
|
||||
(apply
|
||||
string-append
|
||||
(map
|
||||
(lambda (n) (format "~a~a" sep n))
|
||||
(cdr l))))))
|
||||
|
||||
(define (data-lines->data datas)
|
||||
(splice datas (format "~a~a~a" #\return #\linefeed #\tab)))
|
||||
|
||||
;;; Extracting Addresses ;;;
|
||||
|
||||
(define blank (format "[~a~a~a~a~a]" #\space #\tab #\newline #\return #\vtab))
|
||||
(define re:all-blank (regexp (format "^~a*$" blank)))
|
||||
|
||||
(define (extract-addresses s form)
|
||||
(unless (memq form '(name address full all))
|
||||
(raise-type-error 'extract-addresses
|
||||
"form: 'name, 'address, 'full, or 'all"
|
||||
form))
|
||||
(if (or (not s) (regexp-match re:all-blank s))
|
||||
null
|
||||
(let loop ([prefix ""][s s])
|
||||
; Which comes first - a quote or a comma?
|
||||
(let ([mq (regexp-match-positions "\"[^\"]*\"" s)]
|
||||
[mc (regexp-match-positions "," s)])
|
||||
(if (and mq mc (< (caar mq) (caar mc) (cdar mq)))
|
||||
; Quote contains a comma
|
||||
(loop (string-append
|
||||
prefix
|
||||
(substring s 0 (cdar mq)))
|
||||
(substring s (cdar mq) (string-length s)))
|
||||
; Normal comma parsing:
|
||||
(let ([m (regexp-match "([^,]*),(.*)" s)])
|
||||
(if m
|
||||
(let ([n (extract-one-name (string-append prefix (cadr m)) form)]
|
||||
[rest (extract-addresses (caddr m) form)])
|
||||
(cons n rest))
|
||||
(let ([n (extract-one-name (string-append prefix s) form)])
|
||||
(list n)))))))))
|
||||
|
||||
(define (select-result form name addr full)
|
||||
(case form
|
||||
[(name) name]
|
||||
[(address) addr]
|
||||
[(full) full]
|
||||
[(all) (list name addr full)]))
|
||||
|
||||
(define (one-result form s)
|
||||
(select-result form s s s))
|
||||
|
||||
(define (extract-one-name s form)
|
||||
(cond
|
||||
[(regexp-match (format "^~a*(\"[^\"]*\")(.*)" blank) s)
|
||||
=> (lambda (m)
|
||||
(let ([name (cadr m)]
|
||||
[addr (extract-angle-addr (caddr m))])
|
||||
(select-result form name addr
|
||||
(format "~a <~a>" name addr))))]
|
||||
; ?!?!? Where does the "addr (name)" standard come from ?!?!?
|
||||
[(regexp-match (format "(.*)[(]([^)]*)[)]~a*$" blank) s)
|
||||
=> (lambda (m)
|
||||
(let ([name (caddr m)]
|
||||
[addr (extract-simple-addr (cadr m))])
|
||||
(select-result form name addr
|
||||
(format "~a (~a)" addr name))))]
|
||||
[(regexp-match (format "^~a*(.*)(<.*>)~a*$" blank blank) s)
|
||||
=> (lambda (m)
|
||||
(let ([name (regexp-replace (format "~a*$" blank) (cadr m) "")]
|
||||
[addr (extract-angle-addr (caddr m))])
|
||||
(select-result form name addr
|
||||
(format "~a <~a>" name addr))))]
|
||||
[(or (regexp-match "<" s) (regexp-match ">" s))
|
||||
(one-result form (extract-angle-addr s))]
|
||||
[else
|
||||
(one-result form (extract-simple-addr s))]))
|
||||
|
||||
(define (extract-angle-addr s)
|
||||
(if (or (regexp-match "<.*<" s) (regexp-match ">.*>" s))
|
||||
(error 'extract-address "too many angle brackets: ~a" s)
|
||||
(let ([m (regexp-match (format "~a*<([^>]*)>~a*" blank blank) s)])
|
||||
(if m
|
||||
(extract-simple-addr (cadr m))
|
||||
(error 'extract-address "cannot parse address: ~a" s)))))
|
||||
|
||||
(define (extract-simple-addr s)
|
||||
(cond
|
||||
[(regexp-match "[,\"()<>]" s)
|
||||
(error 'extract-address "cannot parse address: ~a" s)]
|
||||
[else
|
||||
; final whitespace strip
|
||||
(regexp-replace
|
||||
(format "~a*$" blank)
|
||||
(regexp-replace (format "~a*" blank) s "")
|
||||
"")]))
|
||||
|
||||
(define (assemble-address-field addresses)
|
||||
(if (null? addresses)
|
||||
""
|
||||
(let loop ([addresses (cdr addresses)]
|
||||
[s (car addresses)]
|
||||
[len (string-length (car addresses))])
|
||||
(if (null? addresses)
|
||||
s
|
||||
(let* ([addr (car addresses)]
|
||||
[alen (string-length addr)])
|
||||
(if (<= 72 (+ len alen))
|
||||
(loop (cdr addresses)
|
||||
(format "~a,~a~a~a~a"
|
||||
s #\return #\linefeed
|
||||
#\tab addr)
|
||||
alen)
|
||||
(loop (cdr addresses)
|
||||
(format "~a, ~a" s addr)
|
||||
(+ len alen 2)))))))))
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
|
||||
(define-signature mzlib:head^
|
||||
(empty-header
|
||||
validate-header
|
||||
extract-field
|
||||
remove-field
|
||||
insert-field
|
||||
append-headers
|
||||
standard-message-header
|
||||
data-lines->data
|
||||
extract-addresses
|
||||
assemble-address-field))
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
|
||||
(require-relative-library "imaps.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:imap^
|
||||
(require-relative-library "imapr.ss"))
|
||||
|
|
@ -1,379 +0,0 @@
|
|||
|
||||
(unit/sig mzlib:imap^
|
||||
(import)
|
||||
|
||||
(define debug-via-stdio? #f)
|
||||
|
||||
(define eol (if debug-via-stdio?
|
||||
'linefeed
|
||||
'return-linefeed))
|
||||
|
||||
(define crlf (string #\return #\linefeed))
|
||||
|
||||
(define (tag-eq? a b)
|
||||
(or (eq? a b)
|
||||
(and (symbol? a)
|
||||
(symbol? b)
|
||||
(string-ci=? (symbol->string a)
|
||||
(symbol->string b)))))
|
||||
|
||||
(define field-names
|
||||
(list
|
||||
(list 'uid (string->symbol "UID"))
|
||||
(list 'header (string->symbol "RFC822.HEADER"))
|
||||
(list 'body (string->symbol "RFC822.TEXT"))
|
||||
(list 'size (string->symbol "RFC822.SIZE"))
|
||||
(list 'flags (string->symbol "FLAGS"))))
|
||||
|
||||
(define flag-names
|
||||
(list
|
||||
(list 'seen (string->symbol "\\Seen"))
|
||||
(list 'answered (string->symbol "\\Answered"))
|
||||
(list 'flagged (string->symbol "\\Flagged"))
|
||||
(list 'deleted (string->symbol "\\Deleted"))
|
||||
(list 'draft (string->symbol "\\Draft"))
|
||||
(list 'recent (string->symbol "\\Recent"))
|
||||
|
||||
(list 'noinferiors (string->symbol "\\Noinferiors"))
|
||||
(list 'noselect (string->symbol "\\Noselect"))
|
||||
(list 'marked (string->symbol "\\Marked"))
|
||||
(list 'unmarked (string->symbol "\\Unmarked"))))
|
||||
|
||||
(define (imap-flag->symbol f)
|
||||
(or (ormap (lambda (a) (and (tag-eq? f (cadr a)) (car a)))
|
||||
flag-names)
|
||||
f))
|
||||
|
||||
(define (symbol->imap-flag s)
|
||||
(let ([a (assoc s flag-names)])
|
||||
(if a
|
||||
(cadr a)
|
||||
s)))
|
||||
|
||||
(define (log-warning . args)
|
||||
; (apply printf args)
|
||||
(void))
|
||||
(define log log-warning)
|
||||
|
||||
(define make-msg-id
|
||||
(let ([id 0])
|
||||
(lambda ()
|
||||
(begin0
|
||||
(format "a~a " id)
|
||||
(set! id (add1 id))))))
|
||||
|
||||
(define (starts-with? l n)
|
||||
(and (>= (string-length l) (string-length n))
|
||||
(string=? n (substring l 0 (string-length n)))))
|
||||
|
||||
(define (skip s n)
|
||||
(substring s
|
||||
(if (number? n) n (string-length n))
|
||||
(string-length s)))
|
||||
|
||||
(define (splice l sep)
|
||||
(if (null? l)
|
||||
""
|
||||
(format "~a~a"
|
||||
(car l)
|
||||
(apply
|
||||
string-append
|
||||
(map
|
||||
(lambda (n) (format "~a~a" sep n))
|
||||
(cdr l))))))
|
||||
|
||||
(define (imap-read s r)
|
||||
(let loop ([s s]
|
||||
[r r]
|
||||
[accum null]
|
||||
[eol-k (lambda (accum) (reverse! accum))]
|
||||
[eop-k (lambda (s accum) (error 'imap-read "unxpected close parenthesis"))])
|
||||
(cond
|
||||
[(string=? "" s) (eol-k accum)]
|
||||
[(char-whitespace? (string-ref s 0))
|
||||
(loop (skip s 1) r accum eol-k eop-k)]
|
||||
[else
|
||||
(case (string-ref s 0)
|
||||
[(#\") (let ([m (regexp-match "\"([^\"]*)\"(.*)" s)])
|
||||
(if m
|
||||
(loop (caddr m) r (cons (cadr m) accum) eol-k eop-k)
|
||||
(error 'imap-read "didn't find end of quoted string in: ~a" s)))]
|
||||
[(#\)) (eop-k (skip s 1) accum)]
|
||||
[(#\() (letrec ([next-line
|
||||
(lambda (accum)
|
||||
(loop (read-line r eol) r
|
||||
accum
|
||||
next-line
|
||||
finish-parens))]
|
||||
[finish-parens
|
||||
(lambda (s laccum)
|
||||
(loop s r
|
||||
(cons (reverse! laccum) accum)
|
||||
eol-k eop-k))])
|
||||
(loop (skip s 1) r null next-line finish-parens))]
|
||||
[(#\{) (let ([m (regexp-match "{([0-9]+)}(.*)" s)])
|
||||
(cond
|
||||
[(not m) (error 'imap-read "couldn't read {} number: ~a" s)]
|
||||
[(not (string=? (caddr m) "")) (error 'imap-read "{} not at end-of-line: ~a" s)]
|
||||
[else (loop "" r
|
||||
(cons (read-string (string->number (cadr m)) r)
|
||||
accum)
|
||||
eol-k eop-k)]))]
|
||||
[else (let ([m (regexp-match "([^ (){}]+)(.*)" s)])
|
||||
(if m
|
||||
(loop (caddr m) r
|
||||
(cons (let ([v (cadr m)])
|
||||
(if (regexp-match "^[0-9]*$" v)
|
||||
(string->number v)
|
||||
(string->symbol (cadr m))))
|
||||
accum)
|
||||
eol-k eop-k)
|
||||
(error 'imap-read "failure reading atom: ~a" s)))])])))
|
||||
|
||||
(define (imap-send r w cmd info-handler)
|
||||
(let ([id (make-msg-id)])
|
||||
(log "sending ~a~a~n" id cmd)
|
||||
(fprintf w "~a~a~a" id cmd crlf)
|
||||
(let loop ()
|
||||
(let ([l (read-line r eol)])
|
||||
; (log "raw-reply: ~s~n" l)
|
||||
(cond
|
||||
[(starts-with? l id)
|
||||
(let ([reply (imap-read (skip l id) r)])
|
||||
(log "response: ~a~n" reply)
|
||||
reply)]
|
||||
[(starts-with? l "* ")
|
||||
(let ([info (imap-read (skip l 2) r)])
|
||||
(log "info: ~s~n" info)
|
||||
(info-handler info))
|
||||
(loop)]
|
||||
[(starts-with? l "+ ")
|
||||
(error 'imap-send "unexpected continuation request: ~a" l)]
|
||||
[else
|
||||
(log-warning "warning: unexpected response for ~a: ~a" id l)
|
||||
(loop)])))))
|
||||
|
||||
(define (str->arg s)
|
||||
(if (or (regexp-match " " s)
|
||||
(string=? s ""))
|
||||
(format "\"~a\"" s)
|
||||
s))
|
||||
|
||||
(define (check-ok reply)
|
||||
(unless (and (pair? reply)
|
||||
(tag-eq? (car reply) 'OK))
|
||||
(error 'check-ok "server error: ~s" reply)))
|
||||
|
||||
(define-struct imap-connection (r w))
|
||||
|
||||
(define imap-port-number (make-parameter 143))
|
||||
|
||||
(define (imap-connect server username password inbox)
|
||||
; => imap count-k recent-k
|
||||
(let-values ([(r w) (if debug-via-stdio?
|
||||
(begin
|
||||
(printf "stdin == ~a~n" server)
|
||||
(values (current-input-port) (current-output-port)))
|
||||
(tcp-connect server (imap-port-number)))])
|
||||
(with-handlers ([void
|
||||
(lambda (x)
|
||||
(close-input-port r)
|
||||
(close-output-port w)
|
||||
(raise x))])
|
||||
|
||||
(check-ok (imap-send r w "NOOP" void))
|
||||
(let ([reply (imap-send r w (format "LOGIN ~a ~a"
|
||||
(str->arg username)
|
||||
(str->arg password))
|
||||
void)])
|
||||
(if (and (pair? reply) (tag-eq? 'NO (car reply)))
|
||||
(error "username or password rejected by server")
|
||||
(check-ok reply)))
|
||||
|
||||
(let ([imap (make-imap-connection r w)])
|
||||
(let-values ([(init-count init-recent)
|
||||
(imap-reselect imap inbox)])
|
||||
(values imap
|
||||
init-count
|
||||
init-recent))))))
|
||||
|
||||
(define (imap-reselect imap inbox)
|
||||
(let ([r (imap-connection-r imap)]
|
||||
[w (imap-connection-w imap)])
|
||||
(let ([init-count 0]
|
||||
[init-recent 0])
|
||||
(check-ok (imap-send r w (format "SELECT ~a" (str->arg inbox))
|
||||
(lambda (i)
|
||||
(when (and (list? i) (= 2 (length i)))
|
||||
(cond
|
||||
[(tag-eq? (cadr i) 'EXISTS)
|
||||
(set! init-count (car i))]
|
||||
[(tag-eq? (cadr i) 'RECENT)
|
||||
(set! init-recent (car i))])))))
|
||||
(values init-count init-recent))))
|
||||
|
||||
(define (imap-status imap inbox flags)
|
||||
(unless (and (list? flags)
|
||||
(andmap (lambda (s)
|
||||
(memq s '(messages recent uidnext uidvalidity unseen)))
|
||||
flags))
|
||||
(raise-type-error 'imap-status "list of status flag symbols" flags))
|
||||
(let ([r (imap-connection-r imap)]
|
||||
[w (imap-connection-w imap)])
|
||||
(let ([results null])
|
||||
(check-ok (imap-send r w (format "STATUS ~a ~a" (str->arg inbox) flags)
|
||||
(lambda (i)
|
||||
(when (and (list? i) (= 3 (length i))
|
||||
(tag-eq? (car i) 'STATUS))
|
||||
(set! results (caddr i))))))
|
||||
(map
|
||||
(lambda (f)
|
||||
(let loop ([l results])
|
||||
(cond
|
||||
[(or (null? l) (null? (cdr l))) #f]
|
||||
[(tag-eq? f (car l)) (cadr l)]
|
||||
[else (loop (cdr l))])))
|
||||
flags))))
|
||||
|
||||
(define (imap-disconnect imap)
|
||||
(let ([r (imap-connection-r imap)]
|
||||
[w (imap-connection-w imap)])
|
||||
(check-ok (imap-send r w "LOGOUT" void))
|
||||
(close-input-port r)
|
||||
(close-output-port w)))
|
||||
|
||||
(define (imap-force-disconnect imap)
|
||||
(let ([r (imap-connection-r imap)]
|
||||
[w (imap-connection-w imap)])
|
||||
(close-input-port r)
|
||||
(close-output-port w)))
|
||||
|
||||
(define (imap-get-messages imap msgs field-list)
|
||||
(let ([r (imap-connection-r imap)]
|
||||
[w (imap-connection-w imap)])
|
||||
(when (or (not (list? msgs))
|
||||
(not (andmap integer? msgs)))
|
||||
(raise-type-error 'imap-get-messages "non-empty message list" msgs))
|
||||
(when (or (null? field-list)
|
||||
(not (list? field-list))
|
||||
(not (andmap (lambda (f) (assoc f field-names)) field-list)))
|
||||
(raise-type-error 'imap-get-messages "non-empty field list" field-list))
|
||||
|
||||
(if (null? msgs)
|
||||
null
|
||||
(let ([results null])
|
||||
(imap-send r w (format "FETCH ~a (~a)"
|
||||
(splice msgs ",")
|
||||
(splice (map (lambda (f) (cadr (assoc f field-names))) field-list) " "))
|
||||
(lambda (i)
|
||||
(when (and (list? i) (<= 2 (length i))
|
||||
(tag-eq? (cadr i) 'FETCH))
|
||||
(set! results (cons i results)))))
|
||||
(map
|
||||
(lambda (msg)
|
||||
(let ([m (assoc msg results)])
|
||||
(unless m
|
||||
(error 'imap-get-messages "no result for message ~a" msg))
|
||||
(let ([d (caddr m)])
|
||||
(map
|
||||
(lambda (f)
|
||||
(let ([fld (cadr (assoc f field-names))])
|
||||
(let loop ([d d])
|
||||
(cond
|
||||
[(null? d) #f]
|
||||
[(null? (cdr d)) #f]
|
||||
[(tag-eq? (car d) fld) (cadr d)]
|
||||
[else (loop (cddr d))]))))
|
||||
field-list))))
|
||||
msgs)))))
|
||||
|
||||
(define (imap-store imap mode msgs flags)
|
||||
(let ([r (imap-connection-r imap)]
|
||||
[w (imap-connection-w imap)])
|
||||
(check-ok
|
||||
(imap-send r w
|
||||
(format "STORE ~a ~a ~a"
|
||||
(splice msgs ",")
|
||||
(case mode
|
||||
[(+) "+FLAGS.SILENT"]
|
||||
[(-) "-FLAGS.SILENT"]
|
||||
[(!) "FLAGS.SILENT"]
|
||||
[else (raise-type-error
|
||||
'imap-store
|
||||
"mode: '!, '+, or '-")])
|
||||
flags)
|
||||
void))))
|
||||
|
||||
(define (imap-copy imap msgs dest-mailbox)
|
||||
(let ([r (imap-connection-r imap)]
|
||||
[w (imap-connection-w imap)])
|
||||
(check-ok
|
||||
(imap-send r w
|
||||
(format "COPY ~a ~a"
|
||||
(splice msgs ",")
|
||||
(str->arg dest-mailbox))
|
||||
void))))
|
||||
|
||||
(define (imap-expunge imap)
|
||||
(let ([r (imap-connection-r imap)]
|
||||
[w (imap-connection-w imap)])
|
||||
(check-ok (imap-send r w "EXPUNGE" void))))
|
||||
|
||||
|
||||
(define (imap-mailbox-exists? imap mailbox)
|
||||
(let ([r (imap-connection-r imap)]
|
||||
[w (imap-connection-w imap)]
|
||||
[exists? #f])
|
||||
(check-ok (imap-send r w
|
||||
(format "LIST \"\" ~s" (str->arg mailbox))
|
||||
(lambda (i)
|
||||
(when (and (pair? i)
|
||||
(tag-eq? (car i) 'LIST))
|
||||
(set! exists? #t)))))
|
||||
exists?))
|
||||
|
||||
(define (imap-create-mailbox imap mailbox)
|
||||
(let ([r (imap-connection-r imap)]
|
||||
[w (imap-connection-w imap)])
|
||||
(check-ok
|
||||
(imap-send r w
|
||||
(format "CREATE ~a" (str->arg mailbox))
|
||||
void))))
|
||||
|
||||
(define (imap-get-hierarchy-delimiter imap)
|
||||
(let* ([r (imap-connection-r imap)]
|
||||
[w (imap-connection-w imap)]
|
||||
[result #f])
|
||||
(check-ok
|
||||
(imap-send r w "LIST \"\" \"\""
|
||||
(lambda (x)
|
||||
(set! result (caddr x)))))
|
||||
result))
|
||||
|
||||
(define imap-list-child-mailboxes
|
||||
(case-lambda
|
||||
[(imap mailbox)
|
||||
(imap-list-child-mailboxes imap mailbox (imap-get-hierarchy-delimiter imap))]
|
||||
[(imap mailbox delimiter)
|
||||
(let* ([r (imap-connection-r imap)]
|
||||
[w (imap-connection-w imap)]
|
||||
[mailbox-name (and mailbox (format "~a~a" mailbox delimiter))]
|
||||
[pattern (if mailbox
|
||||
(format "~a%" mailbox-name)
|
||||
"%")]
|
||||
[sub-folders null])
|
||||
(check-ok
|
||||
(imap-send r w (format "LIST \"\" ~a" (str->arg pattern))
|
||||
(lambda (x)
|
||||
(let ([flags (cadr x)]
|
||||
[name (let ([s (cadddr x)])
|
||||
(if (symbol? s)
|
||||
(symbol->string s)
|
||||
s))])
|
||||
(unless (and mailbox-name
|
||||
(string=? name mailbox-name))
|
||||
(set! sub-folders
|
||||
(cons
|
||||
(list flags name)
|
||||
sub-folders)))))))
|
||||
(reverse sub-folders))])))
|
||||
|
|
@ -1,20 +0,0 @@
|
|||
|
||||
(define-signature mzlib:imap^
|
||||
(imap-port-number
|
||||
|
||||
imap-connect
|
||||
imap-disconnect
|
||||
imap-force-disconnect
|
||||
imap-reselect
|
||||
imap-status
|
||||
|
||||
imap-get-messages
|
||||
imap-copy
|
||||
imap-store imap-flag->symbol symbol->imap-flag
|
||||
imap-expunge
|
||||
|
||||
imap-mailbox-exists?
|
||||
imap-create-mailbox
|
||||
|
||||
imap-list-child-mailboxes
|
||||
imap-get-hierarchy-delimiter))
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
(lambda (sym fail)
|
||||
(let ([elab (list "cgis.ss" "mails.ss" "nntps.ss" "pop3s.ss" "urls.ss"
|
||||
"smtps.ss" "heads.ss" "imaps.ss" "dnss.ss" "base64s.ss")])
|
||||
(case sym
|
||||
[(name) "Net"]
|
||||
[(compile-prefix) `(begin ,@(map (lambda (x) `(require-library ,x "net")) elab))]
|
||||
[(compile-omit-files) elab]
|
||||
[(compile-elaboration-zos) elab]
|
||||
[else (fail)])))
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
(require-library "mails.ss" "net")
|
||||
(require-library "mailu.ss" "net")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:sendmail^
|
||||
mzlib:sendmail@)
|
||||
|
|
@ -1,105 +0,0 @@
|
|||
(unit/sig mzlib:sendmail^
|
||||
(import)
|
||||
|
||||
(define-struct (no-mail-recipients struct:exn) ())
|
||||
|
||||
(define sendmail-search-path
|
||||
'("/usr/lib" "/usr/sbin"))
|
||||
|
||||
(define sendmail-program-file
|
||||
(if (eq? (system-type) 'unix)
|
||||
(let loop ((paths sendmail-search-path))
|
||||
(if (null? paths)
|
||||
(raise (make-exn:misc:unsupported
|
||||
"unable to find sendmail on this Unix variant"
|
||||
(current-continuation-marks)))
|
||||
(let ((p (build-path (car paths) "sendmail")))
|
||||
(if (and (file-exists? p)
|
||||
(memq 'execute (file-or-directory-permissions p)))
|
||||
p
|
||||
(loop (cdr paths))))))
|
||||
(raise (make-exn:misc:unsupported
|
||||
"sendmail only available under Unix"
|
||||
(current-continuation-marks)))))
|
||||
|
||||
;; send-mail-message/port :
|
||||
;; string x string x list (string) x list (string) x list (string)
|
||||
;; [x list (string)] -> oport
|
||||
|
||||
;; -- sender can be anything, though spoofing is not recommended.
|
||||
;; The recipients must all be pure email addresses. Note that
|
||||
;; everything is expected to follow RFC conventions. If any other
|
||||
;; headers are specified, they are expected to be completely
|
||||
;; formatted already. Clients are urged to use close-output-port on
|
||||
;; the port returned by this procedure as soon as the necessary text
|
||||
;; has been written, so that the sendmail process can complete.
|
||||
|
||||
(define send-mail-message/port
|
||||
(lambda (sender subject to-recipients cc-recipients bcc-recipients
|
||||
. other-headers)
|
||||
(when (and (null? to-recipients) (null? cc-recipients)
|
||||
(null? bcc-recipients))
|
||||
(raise (make-no-mail-recipients
|
||||
"no mail recipients were specified"
|
||||
(current-continuation-marks))))
|
||||
(let ((return (apply process* sendmail-program-file "-i"
|
||||
(append to-recipients cc-recipients bcc-recipients))))
|
||||
(let ((reader (car return))
|
||||
(writer (cadr return))
|
||||
(pid (caddr return))
|
||||
(error-reader (cadddr return)))
|
||||
(close-input-port reader)
|
||||
(close-input-port error-reader)
|
||||
(fprintf writer "From: ~a~n" sender)
|
||||
(letrec ((write-recipient-header
|
||||
(lambda (header-string recipients)
|
||||
(let ((header-space
|
||||
(+ (string-length header-string) 2)))
|
||||
(fprintf writer "~a: " header-string)
|
||||
(let loop ((to recipients) (indent header-space))
|
||||
(if (null? to)
|
||||
(newline writer)
|
||||
(let ((first (car to)))
|
||||
(let ((len (string-length first)))
|
||||
(if (>= (+ len indent) 80)
|
||||
(begin
|
||||
(fprintf writer "~n ~a, " first)
|
||||
(loop (cdr to) (+ len header-space 2)))
|
||||
(begin
|
||||
(fprintf writer "~a, " first)
|
||||
(loop (cdr to)
|
||||
(+ len indent 2))))))))))))
|
||||
(write-recipient-header "To" to-recipients)
|
||||
(write-recipient-header "CC" cc-recipients))
|
||||
(fprintf writer "Subject: ~a~n" subject)
|
||||
(fprintf writer "X-Mailer: MzScheme: see www.cs.rice.edu/CS/PLT/~n")
|
||||
(for-each (lambda (s)
|
||||
(display s writer)
|
||||
(newline writer))
|
||||
other-headers)
|
||||
(newline writer)
|
||||
writer))))
|
||||
|
||||
;; send-mail-message :
|
||||
;; string x string x list (string) x list (string) x list (string) x
|
||||
;; list (string) [x list (string)] -> ()
|
||||
|
||||
;; -- sender can be anything, though spoofing is not recommended. The
|
||||
;; recipients must all be pure email addresses. The text is expected
|
||||
;; to be pre-formatted. Note that everything is expected to follow
|
||||
;; RFC conventions. If any other headers are specified, they are
|
||||
;; expected to be completely formatted already.
|
||||
|
||||
(define send-mail-message
|
||||
(lambda (sender subject to-recipients cc-recipients bcc-recipients text
|
||||
. other-headers)
|
||||
(let ((writer (apply send-mail-message/port sender subject
|
||||
to-recipients cc-recipients bcc-recipients
|
||||
other-headers)))
|
||||
(for-each (lambda (s)
|
||||
(display s writer) ; We use -i, so "." is not a problem
|
||||
(newline writer))
|
||||
text)
|
||||
(close-output-port writer))))
|
||||
|
||||
)
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
(define-signature mzlib:sendmail^
|
||||
(send-mail-message/port
|
||||
send-mail-message
|
||||
(struct no-mail-recipients ())))
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
(require-library "mails.ss" "net")
|
||||
|
||||
(define mzlib:sendmail@
|
||||
(require-library-unit/sig "mailr.ss" "net"))
|
||||
|
|
@ -1,128 +0,0 @@
|
|||
(define nntp-doc
|
||||
(mk-document {nntp}
|
||||
{The PLT NNTP Toolkit}
|
||||
|
||||
{[(paragraph {The NNTP toolkit implements routines which form the
|
||||
basis for a client that can converse with an NNTP (Usenet
|
||||
News) server. The toolkit defines both procedures to
|
||||
interface with the server, and exceptions which indicate
|
||||
erroneous behavior.})]
|
||||
|
||||
[(paragraph
|
||||
{The toolkit is parameterized over [(italic
|
||||
{communicator})]s, which are structures representing a
|
||||
connection to a particular server. Several communicators can
|
||||
be open at any given time. A communicator has four fields:
|
||||
|
||||
[(mk-itemize
|
||||
(list
|
||||
{[(italic {sender})], an output port which sends
|
||||
commands to the the server;
|
||||
}
|
||||
{[(italic {receiver})], an input port for receiving
|
||||
responses from the server;
|
||||
}
|
||||
{[(italic {server})], a string containing the name of
|
||||
the server, which is useful for error messages and
|
||||
identification; and,
|
||||
}
|
||||
{[(italic {port})], a number denoting the port number
|
||||
on the server to which this connection was
|
||||
established.
|
||||
}))]})]
|
||||
|
||||
[(paragraph {The following procedures are defined:})]
|
||||
|
||||
[(mk-itemize
|
||||
(list
|
||||
{[(bold {connect-to-server})] accepts a string, the server's
|
||||
name, and optionally the port number. If no port number
|
||||
is provided, the default NNTP port (119) is used. A
|
||||
communicator is returned.}
|
||||
{[(bold {disconnect-from-server})] takes a communicator and
|
||||
closes its connections.}
|
||||
{[(bold {open-news-group})] accepts a communicator and a
|
||||
string, representing the group's name, and makes it the
|
||||
current group. Three values are returned: the number of
|
||||
articles the server has for the group, the first
|
||||
available article number, and the last article number.}
|
||||
{[(bold {head-of-message})] takes a communicator and a
|
||||
message number, and returns the message's headers as a
|
||||
list of strings.}
|
||||
{[(bold {body-of-message})] takes a communicator and a
|
||||
message number, and returns the message's body as a list
|
||||
of strings.}
|
||||
{[(bold {make-desired-header})] takes a string representing a
|
||||
header, and returns a regular expression which can be
|
||||
matched against header lines. The string should be given
|
||||
sans a trailing colon; regular expressions may be used
|
||||
within the string.}
|
||||
{[(bold {extract-desired-headers})] accepts a list of strings
|
||||
representing the header and a list of regular expressions
|
||||
representing desired headers, and returns a list of
|
||||
strings denoting the desired headers.}))]
|
||||
|
||||
[(paragraph {This library only interfaces using the NNTP
|
||||
protocol; it does not attempt to improve it by providing an
|
||||
alternative, perhaps more functional, formulation. Hence, it
|
||||
generates the same errors as those returned by NNTP servers.
|
||||
These errors are expressed as Scheme exceptions. They are
|
||||
all sub-types of the exception [(bold {nntp})] (which has
|
||||
no fields).})]
|
||||
|
||||
[(itemize
|
||||
{[(bold {unexpected-response})] has two fields: [(italic
|
||||
{code})], a number and [(italic {text})], a string containing
|
||||
the error message returned by the server. This is raised
|
||||
when the return code is not recognized by the toolkit.}
|
||||
|
||||
{[(bold {premature-close})] is raised when the server
|
||||
generates an end-of-file in the midst of a multi-line
|
||||
response (such as the message header or body). The exception
|
||||
has a [(italic {communicator})] field.}
|
||||
|
||||
{[(bold {non-existent-group})] is raised when the group being
|
||||
opened is not recognized by the server. Note that not all
|
||||
servers carry all groups.}
|
||||
|
||||
{[(bold {article-not-in-group})] is raised when an attempt is
|
||||
made to get the header or body of a group outside the range
|
||||
for the group or which has expired or been cancelled. The
|
||||
[(italic {article})] field holds the article number.}
|
||||
|
||||
{[(bold {article-not-found})] is raised in other situations
|
||||
when an article cannot be found. The article number is given
|
||||
in the [(italic {article})] field.}
|
||||
|
||||
{[(bold {no-group-selected})] is raised when an attempt is
|
||||
made to get the header or body of an article before any group
|
||||
has been selected.}
|
||||
|
||||
{[(bold {bad-newsgroup-line})] is raised when the server is
|
||||
not following the RFC specification acknowledging that a
|
||||
newsgroup has been set. It holds the line in the [(italic
|
||||
{line})] field.}
|
||||
|
||||
{[(bold {bad-status-line})] has one field: [(italic {line})],
|
||||
a string. This is only flagged when the server does not
|
||||
follow the RFC specification.})]
|
||||
|
||||
[(paragraph {There are at least two routes to take when
|
||||
improving the library's design. One possibility is to
|
||||
provide a construct, similar to Scheme's i/o functions, in
|
||||
whose dynamic range groups are selected, and inside which all
|
||||
article reading is done. Another approach is to require all
|
||||
article accesses to also specify a group. The current group
|
||||
state would be maintained by the implementation, which can
|
||||
optimize away the need to make the current group setting for
|
||||
each article read. It can also anticipate certain errors.
|
||||
The state would be cached with each communicator.})]
|
||||
|
||||
[(paragraph {This implementation currently provides no posting
|
||||
conveniences, though since the output port to the server is
|
||||
available, the user could implement this. However, that same
|
||||
argument can be made for the rest of the toolkit as well.})]
|
||||
|
||||
}))
|
||||
|
||||
(render-html nntp-doc)
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
(require-library "nntpu.ss" "net")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:nntp^
|
||||
mzlib:nntp@
|
||||
nntp)
|
||||
|
|
@ -1,281 +0,0 @@
|
|||
; Time-stamp: <98/07/14 14:41:20 shriram>
|
||||
; Time-stamp: <97/03/05 15:34:09 shriram>
|
||||
|
||||
(unit/sig mzlib:nntp^
|
||||
(import)
|
||||
|
||||
; sender : oport
|
||||
; receiver : iport
|
||||
; server : string
|
||||
; port : number
|
||||
|
||||
(define-struct communicator (sender receiver server port))
|
||||
|
||||
; code : number
|
||||
; text : string
|
||||
; line : string
|
||||
; communicator : communicator
|
||||
; group : string
|
||||
; article : number
|
||||
|
||||
(define-struct (nntp struct:exn) ())
|
||||
(define-struct (unexpected-response struct:nntp) (code text))
|
||||
(define-struct (bad-status-line struct:nntp) (line))
|
||||
(define-struct (premature-close struct:nntp) (communicator))
|
||||
(define-struct (bad-newsgroup-line struct:nntp) (line))
|
||||
(define-struct (non-existent-group struct:nntp) (group))
|
||||
(define-struct (article-not-in-group struct:nntp) (article))
|
||||
(define-struct (no-group-selected struct:nntp) ())
|
||||
(define-struct (article-not-found struct:nntp) (article))
|
||||
|
||||
; signal-error :
|
||||
; (exn-args ... -> exn) x format-string x values ... ->
|
||||
; exn-args -> ()
|
||||
|
||||
; - throws an exception
|
||||
|
||||
(define signal-error
|
||||
(lambda (constructor format-string . args)
|
||||
(lambda exn-args
|
||||
(raise (apply constructor
|
||||
(apply format format-string args)
|
||||
(current-continuation-marks)
|
||||
exn-args)))))
|
||||
|
||||
; default-nntpd-port-number :
|
||||
; number
|
||||
|
||||
(define default-nntpd-port-number 119)
|
||||
|
||||
; connect-to-server :
|
||||
; string [x number] -> commnicator
|
||||
|
||||
(define connect-to-server
|
||||
(opt-lambda (server-name (port-number default-nntpd-port-number))
|
||||
(let-values (((receiver sender)
|
||||
(tcp-connect server-name port-number)))
|
||||
(let ((communicator
|
||||
(make-communicator sender receiver server-name port-number)))
|
||||
(let-values (((code response)
|
||||
(get-single-line-response communicator)))
|
||||
(case code
|
||||
((200)
|
||||
communicator)
|
||||
(else
|
||||
((signal-error make-unexpected-response
|
||||
"unexpected connection response: ~s ~s"
|
||||
code response)
|
||||
code response))))))))
|
||||
|
||||
; close-communicator :
|
||||
; communicator -> ()
|
||||
|
||||
(define close-communicator
|
||||
(lambda (communicator)
|
||||
(close-input-port (communicator-receiver communicator))
|
||||
(close-output-port (communicator-sender communicator))))
|
||||
|
||||
; disconnect-from-server :
|
||||
; communicator -> ()
|
||||
|
||||
(define disconnect-from-server
|
||||
(lambda (communicator)
|
||||
(send-to-server communicator "QUIT")
|
||||
(let-values (((code response)
|
||||
(get-single-line-response communicator)))
|
||||
(case code
|
||||
((205)
|
||||
(close-communicator communicator))
|
||||
(else
|
||||
((signal-error make-unexpected-response
|
||||
"unexpected dis-connect response: ~s ~s"
|
||||
code response)
|
||||
code response))))))
|
||||
|
||||
; send-to-server :
|
||||
; communicator x format-string x list (values) -> ()
|
||||
|
||||
(define send-to-server
|
||||
(lambda (communicator message-template . rest)
|
||||
(apply fprintf (communicator-sender communicator)
|
||||
(string-append message-template "~n")
|
||||
rest)))
|
||||
|
||||
; parse-status-line :
|
||||
; string -> number x string
|
||||
|
||||
(define parse-status-line
|
||||
(let ((pattern (regexp "([0-9]+) (.*)")))
|
||||
(lambda (line)
|
||||
(let ((match (cdr (or (regexp-match pattern line)
|
||||
((signal-error make-bad-status-line
|
||||
"malformed status line: ~s" line)
|
||||
line)))))
|
||||
(values (string->number (car match))
|
||||
(cadr match))))))
|
||||
|
||||
; get-one-line-from-server :
|
||||
; iport -> string
|
||||
|
||||
(define get-one-line-from-server
|
||||
(lambda (server->client-port)
|
||||
(read-line server->client-port 'return-linefeed)))
|
||||
|
||||
; get-single-line-response :
|
||||
; communicator -> number x string
|
||||
|
||||
(define get-single-line-response
|
||||
(lambda (communicator)
|
||||
(let ((receiver (communicator-receiver communicator)))
|
||||
(let ((status-line (get-one-line-from-server receiver)))
|
||||
(parse-status-line status-line)))))
|
||||
|
||||
; get-rest-of-multi-line-response :
|
||||
; communicator -> list (string)
|
||||
|
||||
(define get-rest-of-multi-line-response
|
||||
(lambda (communicator)
|
||||
(let ((receiver (communicator-receiver communicator)))
|
||||
(let loop ()
|
||||
(let ((l (get-one-line-from-server receiver)))
|
||||
(cond
|
||||
((eof-object? l)
|
||||
((signal-error make-premature-close
|
||||
"port prematurely closed during multi-line response")
|
||||
communicator))
|
||||
((string=? l ".")
|
||||
'())
|
||||
((string=? l "..")
|
||||
(cons "." (loop)))
|
||||
(else
|
||||
(cons l (loop)))))))))
|
||||
|
||||
; get-multi-line-response :
|
||||
; communicator -> number x string x list (string)
|
||||
|
||||
; -- The returned values are the status code, the rest of the status
|
||||
; response line, and the remaining lines.
|
||||
|
||||
(define get-multi-line-response
|
||||
(lambda (communicator)
|
||||
(let ((receiver (communicator-receiver communicator)))
|
||||
(let ((status-line (get-one-line-from-server receiver)))
|
||||
(let-values (((code rest-of-line)
|
||||
(parse-status-line status-line)))
|
||||
(values code rest-of-line (get-rest-of-multi-line-response)))))))
|
||||
|
||||
; open-news-group :
|
||||
; communicator x string -> number x number x number
|
||||
|
||||
; -- The returned values are the number of articles, the first
|
||||
; article number, and the last article number for that group.
|
||||
|
||||
(define open-news-group
|
||||
(let ((pattern (regexp "([0-9]+) ([0-9]+) ([0-9]+)")))
|
||||
(lambda (communicator group-name)
|
||||
(send-to-server communicator "GROUP ~a" group-name)
|
||||
(let-values (((code rest-of-line)
|
||||
(get-single-line-response communicator)))
|
||||
(case code
|
||||
((211)
|
||||
(let ((match (map string->number
|
||||
(cdr
|
||||
(or (regexp-match pattern rest-of-line)
|
||||
((signal-error make-bad-newsgroup-line
|
||||
"malformed newsgroup open response: ~s"
|
||||
rest-of-line)
|
||||
rest-of-line))))))
|
||||
(let ((number-of-articles (car match))
|
||||
(first-article-number (cadr match))
|
||||
(last-article-number (caddr match)))
|
||||
(values number-of-articles
|
||||
first-article-number
|
||||
last-article-number))))
|
||||
((411)
|
||||
((signal-error make-non-existent-group
|
||||
"group ~s does not exist on server ~s"
|
||||
group-name (communicator-server communicator))
|
||||
group-name))
|
||||
(else
|
||||
((signal-error make-unexpected-response
|
||||
"unexpected group opening response: ~s" code)
|
||||
code rest-of-line)))))))
|
||||
|
||||
; head/body-of-message :
|
||||
; string x number -> communicator x number -> list (string)
|
||||
|
||||
(define head/body-of-message
|
||||
(lambda (command ok-code)
|
||||
(lambda (communicator message-number)
|
||||
(send-to-server communicator (string-append command " ~a")
|
||||
(number->string message-number))
|
||||
(let-values (((code response)
|
||||
(get-single-line-response communicator)))
|
||||
(if (= code ok-code)
|
||||
(get-rest-of-multi-line-response communicator)
|
||||
(case code
|
||||
((423)
|
||||
((signal-error make-article-not-in-group
|
||||
"article number ~s not in group" message-number)
|
||||
message-number))
|
||||
((412)
|
||||
((signal-error make-no-group-selected
|
||||
"no group selected")))
|
||||
((430)
|
||||
((signal-error make-article-not-found
|
||||
"no article number ~s found" message-number)
|
||||
message-number))
|
||||
(else
|
||||
((signal-error make-unexpected-response
|
||||
"unexpected message access response: ~s" code)
|
||||
code response))))))))
|
||||
|
||||
; head-of-message :
|
||||
; communicator x number -> list (string)
|
||||
|
||||
(define head-of-message
|
||||
(head/body-of-message "HEAD" 221))
|
||||
|
||||
; body-of-message :
|
||||
; communicator x number -> list (string)
|
||||
|
||||
(define body-of-message
|
||||
(head/body-of-message "BODY" 222))
|
||||
|
||||
; make-desired-header :
|
||||
; string -> desired
|
||||
|
||||
(define make-desired-header
|
||||
(lambda (raw-header)
|
||||
(regexp
|
||||
(string-append
|
||||
"^"
|
||||
(list->string
|
||||
(apply append
|
||||
(map (lambda (c)
|
||||
(cond
|
||||
((char-lower-case? c)
|
||||
(list #\[ (char-upcase c) c #\]))
|
||||
((char-upper-case? c)
|
||||
(list #\[ c (char-downcase c) #\]))
|
||||
(else
|
||||
(list c))))
|
||||
(string->list raw-header))))
|
||||
":"))))
|
||||
|
||||
; extract-desired-headers :
|
||||
; list (string) x list (desired) -> list (string)
|
||||
|
||||
(define extract-desired-headers
|
||||
(lambda (headers desireds)
|
||||
(let loop ((headers headers))
|
||||
(if (null? headers) null
|
||||
(let ((first (car headers))
|
||||
(rest (cdr headers)))
|
||||
(if (ormap (lambda (matcher)
|
||||
(regexp-match matcher first))
|
||||
desireds)
|
||||
(cons first (loop rest))
|
||||
(loop rest)))))))
|
||||
|
||||
)
|
||||
|
|
@ -1,19 +0,0 @@
|
|||
(require-library "macro.ss")
|
||||
|
||||
(define-signature mzlib:nntp^
|
||||
((struct communicator (sender receiver server port))
|
||||
connect-to-server disconnect-from-server
|
||||
open-news-group
|
||||
head-of-message body-of-message
|
||||
make-desired-header extract-desired-headers
|
||||
|
||||
(struct nntp ())
|
||||
(struct unexpected-response (code text))
|
||||
(struct bad-status-line (line))
|
||||
(struct premature-close (communicator))
|
||||
(struct bad-newsgroup-line (line))
|
||||
(struct non-existent-group (group))
|
||||
(struct article-not-in-group (article))
|
||||
(struct no-group-selected ())
|
||||
(struct article-not-found (article))))
|
||||
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
(require-library "macro.ss")
|
||||
|
||||
(require-library "nntps.ss" "net")
|
||||
|
||||
(define mzlib:nntp@ (require-library-unit/sig "nntpr.ss" "net"))
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
(require-library "pop3u.ss" "net")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:pop3^
|
||||
mzlib:pop3@ pop3)
|
||||
|
||||
#|
|
||||
|
||||
> (require-library "pop3.ss" "net")
|
||||
> (define c (pop3:connect-to-server "cs.rice.edu"))
|
||||
> (pop3:authenticate/plain-text "scheme" "********" c)
|
||||
> (pop3:get-mailbox-status c)
|
||||
100
|
||||
177824
|
||||
> (pop3:get-message/headers c 100)
|
||||
("Date: Thu, 6 Nov 1997 12:34:18 -0600 (CST)"
|
||||
"Message-Id: <199711061834.MAA11961@new-world.cs.rice.edu>"
|
||||
"From: Shriram Krishnamurthi <shriram@cs.rice.edu>"
|
||||
...
|
||||
"Status: RO")
|
||||
> (pop3:get-message/complete c 100)
|
||||
("Date: Thu, 6 Nov 1997 12:34:18 -0600 (CST)"
|
||||
"Message-Id: <199711061834.MAA11961@new-world.cs.rice.edu>"
|
||||
"From: Shriram Krishnamurthi <shriram@cs.rice.edu>"
|
||||
...
|
||||
"Status: RO")
|
||||
("some body" "text" "goes" "." "here" "." "")
|
||||
> (pop3:disconnect-from-server c)
|
||||
|
||||
|#
|
||||
|
|
@ -1,403 +0,0 @@
|
|||
; Time-stamp: <98/10/09 19:19:06 shriram>
|
||||
|
||||
(unit/sig mzlib:pop3^
|
||||
(import)
|
||||
|
||||
;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose
|
||||
|
||||
;; sender : oport
|
||||
;; receiver : iport
|
||||
;; server : string
|
||||
;; port : number
|
||||
;; state : symbol = (disconnected, authorization, transaction)
|
||||
|
||||
(define-struct communicator (sender receiver server port state))
|
||||
|
||||
(define-struct (pop3 struct:exn) ())
|
||||
(define-struct (cannot-connect struct:pop3) ())
|
||||
(define-struct (username-rejected struct:pop3) ())
|
||||
(define-struct (password-rejected struct:pop3) ())
|
||||
(define-struct (not-ready-for-transaction struct:pop3) (communicator))
|
||||
(define-struct (not-given-headers struct:pop3) (communicator message))
|
||||
(define-struct (illegal-message-number struct:pop3) (communicator message))
|
||||
(define-struct (cannot-delete-message struct:exn) (communicator message))
|
||||
(define-struct (disconnect-not-quiet struct:pop3) (communicator))
|
||||
(define-struct (malformed-server-response struct:pop3) (communicator))
|
||||
|
||||
;; signal-error :
|
||||
;; (exn-args ... -> exn) x format-string x values ... ->
|
||||
;; exn-args -> ()
|
||||
|
||||
(define signal-error
|
||||
(lambda (constructor format-string . args)
|
||||
(lambda exn-args
|
||||
(raise (apply constructor
|
||||
(apply format format-string args)
|
||||
(current-continuation-marks)
|
||||
exn-args)))))
|
||||
|
||||
;; signal-malformed-response-error :
|
||||
;; exn-args -> ()
|
||||
|
||||
;; -- in practice, it takes only one argument: a communicator.
|
||||
|
||||
(define signal-malformed-response-error
|
||||
(signal-error make-malformed-server-response
|
||||
"malformed response from server"))
|
||||
|
||||
;; confirm-transaction-mode :
|
||||
;; communicator x string -> ()
|
||||
|
||||
;; -- signals an error otherwise.
|
||||
|
||||
(define confirm-transaction-mode
|
||||
(lambda (communicator error-message)
|
||||
(unless (eq? (communicator-state communicator) 'transaction)
|
||||
((signal-error make-not-ready-for-transaction error-message)
|
||||
communicator))))
|
||||
|
||||
;; default-pop-port-number :
|
||||
;; number
|
||||
|
||||
(define default-pop-port-number 110)
|
||||
|
||||
(define-struct server-responses ())
|
||||
(define-struct (+ok struct:server-responses) ())
|
||||
(define-struct (-err struct:server-responses) ())
|
||||
|
||||
(define +ok (make-+ok))
|
||||
(define -err (make--err))
|
||||
|
||||
;; connect-to-server :
|
||||
;; string [x number] -> communicator
|
||||
|
||||
(define connect-to-server
|
||||
(opt-lambda (server-name (port-number default-pop-port-number))
|
||||
(let-values (((receiver sender)
|
||||
(tcp-connect server-name port-number)))
|
||||
(let ((communicator
|
||||
(make-communicator sender receiver server-name port-number
|
||||
'authorization)))
|
||||
(let ((response (get-status-response/basic communicator)))
|
||||
(cond
|
||||
((+ok? response) communicator)
|
||||
((-err? response)
|
||||
((signal-error make-cannot-connect
|
||||
"cannot connect to ~a on port ~a"
|
||||
server-name port-number)))))))))
|
||||
|
||||
;; authenticate/plain-text :
|
||||
;; string x string x communicator -> ()
|
||||
|
||||
;; -- if authentication succeeds, sets the communicator's state to
|
||||
;; transaction.
|
||||
|
||||
(define authenticate/plain-text
|
||||
(lambda (username password communicator)
|
||||
(let ((sender (communicator-sender communicator)))
|
||||
(send-to-server communicator "USER ~a" username)
|
||||
(let ((status (get-status-response/basic communicator)))
|
||||
(cond
|
||||
((+ok? status)
|
||||
(send-to-server communicator "PASS ~a" password)
|
||||
(let ((status (get-status-response/basic communicator)))
|
||||
(cond
|
||||
((+ok? status)
|
||||
(set-communicator-state! communicator 'transaction))
|
||||
((-err? status)
|
||||
((signal-error make-password-rejected
|
||||
"password was rejected"))))))
|
||||
((-err? status)
|
||||
((signal-error make-username-rejected
|
||||
"username was rejected"))))))))
|
||||
|
||||
;; get-mailbox-status :
|
||||
;; communicator -> number x number
|
||||
|
||||
;; -- returns number of messages and number of octets.
|
||||
|
||||
(define get-mailbox-status
|
||||
(let ((stat-regexp (regexp "([0-9]+) ([0-9]+)")))
|
||||
(lambda (communicator)
|
||||
(confirm-transaction-mode communicator
|
||||
"cannot get mailbox status unless in transaction mode")
|
||||
(send-to-server communicator "STAT")
|
||||
(apply values
|
||||
(map string->number
|
||||
(let-values (((status result)
|
||||
(get-status-response/match communicator
|
||||
stat-regexp #f)))
|
||||
result))))))
|
||||
|
||||
;; get-message/complete :
|
||||
;; communicator x number -> list (string) x list (string)
|
||||
|
||||
(define get-message/complete
|
||||
(lambda (communicator message)
|
||||
(confirm-transaction-mode communicator
|
||||
"cannot get message headers unless in transaction state")
|
||||
(send-to-server communicator "RETR ~a" message)
|
||||
(let ((status (get-status-response/basic communicator)))
|
||||
(cond
|
||||
((+ok? status)
|
||||
(split-header/body (get-multi-line-response communicator)))
|
||||
((-err? status)
|
||||
((signal-error make-illegal-message-number
|
||||
"not given message ~a" message)
|
||||
communicator message))))))
|
||||
|
||||
;; get-message/headers :
|
||||
;; communicator x number -> list (string)
|
||||
|
||||
(define get-message/headers
|
||||
(lambda (communicator message)
|
||||
(confirm-transaction-mode communicator
|
||||
"cannot get message headers unless in transaction state")
|
||||
(send-to-server communicator "TOP ~a 0" message)
|
||||
(let ((status (get-status-response/basic communicator)))
|
||||
(cond
|
||||
((+ok? status)
|
||||
(let-values (((headers body)
|
||||
(split-header/body
|
||||
(get-multi-line-response communicator))))
|
||||
headers))
|
||||
((-err? status)
|
||||
((signal-error make-not-given-headers
|
||||
"not given headers to message ~a" message)
|
||||
communicator message))))))
|
||||
|
||||
;; get-message/body :
|
||||
;; communicator x number -> list (string)
|
||||
|
||||
(define get-message/body
|
||||
(lambda (communicator message)
|
||||
(let-values (((headers body)
|
||||
(get-message/complete communicator message)))
|
||||
body)))
|
||||
|
||||
;; split-header/body :
|
||||
;; list (string) -> list (string) x list (string)
|
||||
|
||||
;; -- returns list of headers and list of body lines.
|
||||
|
||||
(define split-header/body
|
||||
(lambda (lines)
|
||||
(let loop ((lines lines) (header null))
|
||||
(if (null? lines)
|
||||
(values (reverse header) null)
|
||||
(let ((first (car lines))
|
||||
(rest (cdr lines)))
|
||||
(if (string=? first "")
|
||||
(values (reverse header) rest)
|
||||
(loop rest (cons first header))))))))
|
||||
|
||||
;; delete-message :
|
||||
;; communicator x number -> ()
|
||||
|
||||
(define delete-message
|
||||
(lambda (communicator message)
|
||||
(confirm-transaction-mode communicator
|
||||
"cannot delete message unless in transaction state")
|
||||
(send-to-server communicator "DELE ~a" message)
|
||||
(let ((status (get-status-response/basic communicator)))
|
||||
(cond
|
||||
((-err? status)
|
||||
((signal-error make-cannot-delete-message
|
||||
"no message numbered ~a available to be deleted" message)
|
||||
communicator message))
|
||||
((+ok? status)
|
||||
'deleted)))))
|
||||
|
||||
;; regexp for UIDL responses
|
||||
|
||||
(define uidl-regexp (regexp "([0-9]+) (.*)"))
|
||||
|
||||
;; get-unique-id/single :
|
||||
;; communicator x number -> string
|
||||
|
||||
(define (get-unique-id/single communicator message)
|
||||
(confirm-transaction-mode communicator
|
||||
"cannot get unique message id unless in transaction state")
|
||||
(send-to-server communicator "UIDL ~a" message)
|
||||
(let-values (((status result)
|
||||
(get-status-response/match communicator
|
||||
uidl-regexp
|
||||
".*")))
|
||||
;; The server response is of the form
|
||||
;; +OK 2 QhdPYR:00WBw1Ph7x7
|
||||
(cond
|
||||
((-err? status)
|
||||
((signal-error make-illegal-message-number
|
||||
"no message numbered ~a available for unique id" message)
|
||||
communicator message))
|
||||
((+ok? status)
|
||||
(cadr result)))))
|
||||
|
||||
;; get-unique-id/all :
|
||||
;; communicator -> list(number x string)
|
||||
|
||||
(define (get-unique-id/all communicator)
|
||||
(confirm-transaction-mode communicator
|
||||
"cannot get unique message ids unless in transaction state")
|
||||
(send-to-server communicator "UIDL")
|
||||
(let ((status (get-status-response/basic communicator)))
|
||||
;; The server response is of the form
|
||||
;; +OK
|
||||
;; 1 whqtswO00WBw418f9t5JxYwZ
|
||||
;; 2 QhdPYR:00WBw1Ph7x7
|
||||
;; .
|
||||
(map (lambda (l)
|
||||
(let ((m (regexp-match uidl-regexp l)))
|
||||
(cons (string->number (cadr m)) (caddr m))))
|
||||
(get-multi-line-response communicator))))
|
||||
|
||||
;; close-communicator :
|
||||
;; communicator -> ()
|
||||
|
||||
(define close-communicator
|
||||
(lambda (communicator)
|
||||
(close-input-port (communicator-receiver communicator))
|
||||
(close-output-port (communicator-sender communicator))))
|
||||
|
||||
;; disconnect-from-server :
|
||||
;; communicator -> ()
|
||||
|
||||
(define disconnect-from-server
|
||||
(lambda (communicator)
|
||||
(send-to-server communicator "QUIT")
|
||||
(set-communicator-state! communicator 'disconnected)
|
||||
(let ((response (get-status-response/basic communicator)))
|
||||
(close-communicator communicator)
|
||||
(cond
|
||||
((+ok? response) (void))
|
||||
((-err? response)
|
||||
((signal-error make-disconnect-not-quiet
|
||||
"got error status upon disconnect")
|
||||
communicator))))))
|
||||
|
||||
;; send-to-server :
|
||||
;; communicator x format-string x list (values) -> ()
|
||||
|
||||
(define send-to-server
|
||||
(lambda (communicator message-template . rest)
|
||||
(apply fprintf (communicator-sender communicator)
|
||||
(string-append message-template "~n")
|
||||
rest)))
|
||||
|
||||
;; get-one-line-from-server :
|
||||
;; iport -> string
|
||||
|
||||
(define get-one-line-from-server
|
||||
(lambda (server->client-port)
|
||||
(read-line server->client-port 'return-linefeed)))
|
||||
|
||||
;; get-server-status-response :
|
||||
;; communicator -> server-responses x string
|
||||
|
||||
;; -- provides the low-level functionality of checking for +OK
|
||||
;; and -ERR, returning an appropriate structure, and returning the
|
||||
;; rest of the status response as a string to be used for further
|
||||
;; parsing, if necessary.
|
||||
|
||||
(define get-server-status-response
|
||||
(let ((+ok-regexp (regexp "^\\+OK (.*)"))
|
||||
(-err-regexp (regexp "^\\-ERR (.*)")))
|
||||
(lambda (communicator)
|
||||
(let ((receiver (communicator-receiver communicator)))
|
||||
(let ((status-line (get-one-line-from-server receiver)))
|
||||
(let ((r (regexp-match +ok-regexp status-line)))
|
||||
(if r
|
||||
(values +ok (cadr r))
|
||||
(let ((r (regexp-match -err-regexp status-line)))
|
||||
(if r
|
||||
(values -err (cadr r))
|
||||
(signal-malformed-response-error communicator))))))))))
|
||||
|
||||
;; get-status-response/basic :
|
||||
;; communicator -> server-responses
|
||||
|
||||
;; -- when the only thing to determine is whether the response
|
||||
;; was +OK or -ERR.
|
||||
|
||||
(define get-status-response/basic
|
||||
(lambda (communicator)
|
||||
(let-values (((response rest)
|
||||
(get-server-status-response communicator)))
|
||||
response)))
|
||||
|
||||
;; get-status-response/match :
|
||||
;; communicator x regexp x regexp -> (status x list (string))
|
||||
|
||||
;; -- when further parsing of the status response is necessary.
|
||||
;; Strips off the car of response from regexp-match.
|
||||
|
||||
(define get-status-response/match
|
||||
(lambda (communicator +regexp -regexp)
|
||||
(let-values (((response rest)
|
||||
(get-server-status-response communicator)))
|
||||
(if (and +regexp (+ok? response))
|
||||
(let ((r (regexp-match +regexp rest)))
|
||||
(if r (values response (cdr r))
|
||||
(signal-malformed-response-error communicator)))
|
||||
(if (and -regexp (-err? response))
|
||||
(let ((r (regexp-match -regexp rest)))
|
||||
(if r (values response (cdr r))
|
||||
(signal-malformed-response-error communicator)))
|
||||
(signal-malformed-response-error communicator))))))
|
||||
|
||||
;; get-multi-line-response :
|
||||
;; communicator -> list (string)
|
||||
|
||||
(define get-multi-line-response
|
||||
(lambda (communicator)
|
||||
(let ((receiver (communicator-receiver communicator)))
|
||||
(let loop ()
|
||||
(let ((l (get-one-line-from-server receiver)))
|
||||
(cond
|
||||
((eof-object? l)
|
||||
(signal-malformed-response-error communicator))
|
||||
((string=? l ".")
|
||||
'())
|
||||
((and (> (string-length l) 1)
|
||||
(char=? (string-ref l 0) #\.))
|
||||
(cons (substring l 1 (string-length l)) (loop)))
|
||||
(else
|
||||
(cons l (loop)))))))))
|
||||
|
||||
;; make-desired-header :
|
||||
;; string -> desired
|
||||
|
||||
(define make-desired-header
|
||||
(lambda (raw-header)
|
||||
(regexp
|
||||
(string-append
|
||||
"^"
|
||||
(list->string
|
||||
(apply append
|
||||
(map (lambda (c)
|
||||
(cond
|
||||
((char-lower-case? c)
|
||||
(list #\[ (char-upcase c) c #\]))
|
||||
((char-upper-case? c)
|
||||
(list #\[ c (char-downcase c) #\]))
|
||||
(else
|
||||
(list c))))
|
||||
(string->list raw-header))))
|
||||
":"))))
|
||||
|
||||
;; extract-desired-headers :
|
||||
;; list (string) x list (desired) -> list (string)
|
||||
|
||||
(define extract-desired-headers
|
||||
(lambda (headers desireds)
|
||||
(let loop ((headers headers))
|
||||
(if (null? headers) null
|
||||
(let ((first (car headers))
|
||||
(rest (cdr headers)))
|
||||
(if (ormap (lambda (matcher)
|
||||
(regexp-match matcher first))
|
||||
desireds)
|
||||
(cons first (loop rest))
|
||||
(loop rest)))))))
|
||||
|
||||
)
|
||||
|
|
@ -1,26 +0,0 @@
|
|||
(require-library "macro.ss")
|
||||
|
||||
(define-signature mzlib:pop3^
|
||||
((struct communicator (sender receiver server port state))
|
||||
connect-to-server disconnect-from-server
|
||||
authenticate/plain-text
|
||||
get-mailbox-status
|
||||
get-message/complete get-message/headers get-message/body
|
||||
delete-message
|
||||
get-unique-id/single get-unique-id/all
|
||||
|
||||
make-desired-header extract-desired-headers
|
||||
|
||||
(struct pop3 ())
|
||||
(struct cannot-connect ())
|
||||
(struct username-rejected ())
|
||||
(struct password-rejected ())
|
||||
(struct not-ready-for-transaction (communicator))
|
||||
(struct not-given-headers (communicator message))
|
||||
(struct illegal-message-number (communicator message))
|
||||
(struct cannot-delete-message (communicator message))
|
||||
(struct disconnect-not-quiet (communicator))
|
||||
(struct malformed-server-response (communicator))
|
||||
|
||||
)
|
||||
)
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
(require-library "macro.ss")
|
||||
|
||||
(require-library "pop3s.ss" "net")
|
||||
|
||||
(define mzlib:pop3@ (require-library-unit/sig "pop3r.ss" "net"))
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
|
||||
(require-relative-library "smtps.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:smtp^
|
||||
(require-relative-library "smtpr.ss"))
|
||||
|
|
@ -1,101 +0,0 @@
|
|||
|
||||
(unit/sig mzlib:smtp^
|
||||
(import)
|
||||
|
||||
(define ID "localhost")
|
||||
|
||||
(define debug-via-stdio? #f)
|
||||
|
||||
(define crlf (string #\return #\linefeed))
|
||||
|
||||
(define (log . args)
|
||||
; (apply printf args)
|
||||
(void))
|
||||
|
||||
(define (starts-with? l n)
|
||||
(and (>= (string-length l) (string-length n))
|
||||
(string=? n (substring l 0 (string-length n)))))
|
||||
|
||||
(define (check-reply r v)
|
||||
(let ([l (read-line r (if debug-via-stdio?
|
||||
'linefeed
|
||||
'return-linefeed))])
|
||||
(log "server: ~a~n" l)
|
||||
(if (eof-object? l)
|
||||
(error 'check-reply "got EOF")
|
||||
(let ([n (number->string v)])
|
||||
(unless (starts-with? l n)
|
||||
(error 'check-reply "expected reply ~a; got: ~a" v l))
|
||||
(let ([n- (string-append n "-")])
|
||||
(when (starts-with? l n-)
|
||||
; Multi-line reply. Go again.
|
||||
(check-reply r v)))))))
|
||||
|
||||
(define (protect-line l)
|
||||
; If begins with a dot, add one more
|
||||
(if (or (string=? "" l) (not (char=? #\. (string-ref l 0))))
|
||||
l
|
||||
(string-append "." l)))
|
||||
|
||||
(define smtp-sending-end-of-message
|
||||
(make-parameter void
|
||||
(lambda (f)
|
||||
(unless (and (procedure? f)
|
||||
(procedure-arity-includes? f 0))
|
||||
(raise-type-error 'smtp-sending-end-of-message "thunk" f))
|
||||
f)))
|
||||
|
||||
(define smtp-send-message
|
||||
(case-lambda
|
||||
[(server sender recipients header message-lines)
|
||||
(smtp-send-message server sender recipients header message-lines 25)]
|
||||
[(server sender recipients header message-lines pos)
|
||||
(when (null? recipients)
|
||||
(error 'send-smtp-message "no recievers"))
|
||||
(let-values ([(r w) (if debug-via-stdio?
|
||||
(values (current-input-port) (current-output-port))
|
||||
(tcp-connect server pos))])
|
||||
(with-handlers ([void (lambda (x)
|
||||
(close-input-port r)
|
||||
(close-output-port w)
|
||||
(raise x))])
|
||||
(check-reply r 220)
|
||||
(log "hello~n")
|
||||
(fprintf w "EHLO ~a~a" ID crlf)
|
||||
(check-reply r 250)
|
||||
|
||||
(log "from~n")
|
||||
(fprintf w "MAIL FROM:<~a>~a" sender crlf)
|
||||
(check-reply r 250)
|
||||
|
||||
(log "to~n")
|
||||
(for-each
|
||||
(lambda (dest)
|
||||
(fprintf w "RCPT TO:<~a>~a" dest crlf)
|
||||
(check-reply r 250))
|
||||
recipients)
|
||||
|
||||
(log "header~n")
|
||||
(fprintf w "DATA~a" crlf)
|
||||
(check-reply r 354)
|
||||
(fprintf w "~a" header)
|
||||
(for-each
|
||||
(lambda (l)
|
||||
(log "body: ~a~n" l)
|
||||
(fprintf w "~a~a" (protect-line l) crlf))
|
||||
message-lines)
|
||||
|
||||
;; After we send the ".", then only break in an emergency
|
||||
((smtp-sending-end-of-message))
|
||||
|
||||
(log "dot~n")
|
||||
(fprintf w ".~a" crlf)
|
||||
(flush-output w)
|
||||
(check-reply r 250)
|
||||
|
||||
(log "quit~n")
|
||||
(fprintf w "QUIT~a" crlf)
|
||||
(check-reply r 221)
|
||||
|
||||
(close-output-port w)
|
||||
(close-input-port r)))])))
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
|
||||
(define-signature mzlib:smtp^
|
||||
(smtp-send-message
|
||||
smtp-sending-end-of-message))
|
||||
|
|
@ -1,20 +0,0 @@
|
|||
(require-library "macro.ss")
|
||||
(require-library "match.ss")
|
||||
(require-library "file.ss")
|
||||
|
||||
(require-library "urlu.ss" "net")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:url^
|
||||
(compound-unit/sig
|
||||
(import
|
||||
(FILE : mzlib:file^))
|
||||
(link
|
||||
(URL : mzlib:url^
|
||||
(mzlib:url@ FILE)))
|
||||
(export
|
||||
(open URL)))
|
||||
#f
|
||||
mzlib:file^)
|
||||
|
|
@ -1,525 +0,0 @@
|
|||
;; To do:
|
||||
;; Handle HTTP/file errors.
|
||||
;; Not throw away MIME headers.
|
||||
;; Determine file type.
|
||||
|
||||
;; ----------------------------------------------------------------------
|
||||
|
||||
;; Input ports have two statuses:
|
||||
;; "impure" = they have text waiting
|
||||
;; "pure" = the MIME headers have been read
|
||||
|
||||
(unit/sig mzlib:url^
|
||||
(import [file : mzlib:file^])
|
||||
|
||||
(define-struct (url-exception struct:exn) ())
|
||||
|
||||
;; This is commented out; it's here for debugging.
|
||||
;; It used to be outside the unit.
|
||||
|
||||
(quote
|
||||
(begin
|
||||
(invoke-open-unit/sig mzlib:url@ #f)
|
||||
(define url:cs (string->url "http://www.cs.rice.edu/"))
|
||||
(define url:me (string->url "http://www.cs.rice.edu/~shriram/"))
|
||||
(define comb combine-url/relative)
|
||||
(define (test url)
|
||||
(call/input-url url
|
||||
get-pure-port
|
||||
display-pure-port))))
|
||||
|
||||
(define url-error
|
||||
(lambda (fmt . args)
|
||||
(let ((s (apply format fmt (map (lambda (arg)
|
||||
(if (url? arg)
|
||||
(url->string arg)
|
||||
arg))
|
||||
args))))
|
||||
(raise (make-url-exception s (current-continuation-marks))))))
|
||||
|
||||
;; if the path is absolute, it just arbitrarily picks the first
|
||||
;; filesystem root.
|
||||
(define unixpath->path
|
||||
(letrec ([r (regexp "([^/]*)/(.*)")]
|
||||
[translate-dir
|
||||
(lambda (s)
|
||||
(cond
|
||||
[(string=? s "") 'same] ;; handle double slashes
|
||||
[(string=? s "..") 'up]
|
||||
[(string=? s ".") 'same]
|
||||
[else s]))]
|
||||
[build-relative-path
|
||||
(lambda (s)
|
||||
(let ([m (regexp-match r s)])
|
||||
(cond
|
||||
[(string=? s "") 'same]
|
||||
[(not m) s]
|
||||
[else
|
||||
(build-path (translate-dir (cadr m))
|
||||
(build-relative-path (caddr m)))])))])
|
||||
(lambda (s)
|
||||
(cond
|
||||
[(string=? s "") ""]
|
||||
[(string=? s "/") (car (filesystem-root-list))]
|
||||
[(char=? #\/ (string-ref s 0))
|
||||
(build-path (car (filesystem-root-list))
|
||||
(build-relative-path
|
||||
(substring s 1 (string-length s))))]
|
||||
[else (build-relative-path s)]))))
|
||||
|
||||
;; scheme : str + #f
|
||||
;; host : str + #f
|
||||
;; port : num + #f
|
||||
;; path : str
|
||||
;; params : str + #f
|
||||
;; query : str + #f
|
||||
;; fragment : str + #f
|
||||
(define-struct url (scheme host port path params query fragment))
|
||||
|
||||
;; name : str (all lowercase; not including the colon)
|
||||
;; value : str (doesn't have the eol delimiter)
|
||||
(define-struct mime-header (name value))
|
||||
|
||||
(define url->string
|
||||
(lambda (url)
|
||||
(let ((scheme (url-scheme url))
|
||||
(host (url-host url))
|
||||
(port (url-port url))
|
||||
(path (url-path url))
|
||||
(params (url-params url))
|
||||
(query (url-query url))
|
||||
(fragment (url-fragment url)))
|
||||
(cond
|
||||
((and scheme (string=? scheme "file"))
|
||||
(string-append "file:" path))
|
||||
(else
|
||||
(let ((sa string-append))
|
||||
(sa (if scheme (sa scheme "://") "")
|
||||
(if host host "")
|
||||
(if port (sa ":" (number->string port)) "")
|
||||
; There used to be a "/" here, but that causes an
|
||||
; extra leading slash -- wonder why it ever worked!
|
||||
path
|
||||
(if params (sa ";" params) "")
|
||||
(if query (sa "?" query) "")
|
||||
(if fragment (sa "#" fragment) ""))))))))
|
||||
|
||||
;; url->default-port : url -> num
|
||||
(define url->default-port
|
||||
(lambda (url)
|
||||
(let ((scheme (url-scheme url)))
|
||||
(cond
|
||||
((not scheme) 80)
|
||||
((string=? scheme "http") 80)
|
||||
(else
|
||||
(url-error "Scheme ~a not supported" (url-scheme url)))))))
|
||||
|
||||
;; make-ports : url -> in-port x out-port
|
||||
(define make-ports
|
||||
(lambda (url)
|
||||
(let ((port-number (or (url-port url)
|
||||
(url->default-port url))))
|
||||
(tcp-connect (url-host url) port-number))))
|
||||
|
||||
;; http://get-impure-port : url [x list (str)] -> in-port
|
||||
(define http://get-impure-port
|
||||
(opt-lambda (url (strings '()))
|
||||
(let-values (((server->client client->server)
|
||||
(make-ports url)))
|
||||
(let ((access-string
|
||||
(url->string
|
||||
(make-url #f #f #f
|
||||
(url-path url) (url-params url)
|
||||
(url-query url) (url-fragment url)))))
|
||||
(for-each (lambda (s)
|
||||
(display s client->server)
|
||||
(newline client->server))
|
||||
(cons (format "GET ~a HTTP/1.0" access-string)
|
||||
(cons (format "Host: ~a" (url-host url))
|
||||
strings))))
|
||||
(newline client->server)
|
||||
(close-output-port client->server)
|
||||
server->client)))
|
||||
|
||||
;; file://get-pure-port : url -> in-port
|
||||
(define file://get-pure-port
|
||||
(lambda (url)
|
||||
(let ((host (url-host url)))
|
||||
(if (or (not host)
|
||||
(string=? host "")
|
||||
(string=? host "localhost"))
|
||||
(open-input-file
|
||||
(unixpath->path (url-path url)))
|
||||
(url-error "Cannot get files from remote hosts")))))
|
||||
|
||||
;; get-impure-port : url [x list (str)] -> in-port
|
||||
(define get-impure-port
|
||||
(opt-lambda (url (strings '()))
|
||||
(let ((scheme (url-scheme url)))
|
||||
(cond
|
||||
((not scheme)
|
||||
(url-error "Scheme unspecified in ~a" url))
|
||||
((string=? scheme "http")
|
||||
(http://get-impure-port url strings))
|
||||
((string=? scheme "file")
|
||||
(url-error "There are no impure file:// ports"))
|
||||
(else
|
||||
(url-error "Scheme ~a unsupported" scheme))))))
|
||||
|
||||
;; get-pure-port : url [x list (str)] -> in-port
|
||||
(define get-pure-port
|
||||
(opt-lambda (url (strings '()))
|
||||
(let ((scheme (url-scheme url)))
|
||||
(cond
|
||||
((not scheme)
|
||||
(url-error "Scheme unspecified in ~a" url))
|
||||
((string=? scheme "http")
|
||||
(let ((port (http://get-impure-port url strings)))
|
||||
(purify-port port)
|
||||
port))
|
||||
((string=? scheme "file")
|
||||
(file://get-pure-port url))
|
||||
(else
|
||||
(url-error "Scheme ~a unsupported" scheme))))))
|
||||
|
||||
;; display-pure-port : in-port -> ()
|
||||
(define display-pure-port
|
||||
(lambda (server->client)
|
||||
(let loop ()
|
||||
(let ((c (read-char server->client)))
|
||||
(unless (eof-object? c)
|
||||
(display c)
|
||||
(loop))))
|
||||
(close-input-port server->client)))
|
||||
|
||||
(define empty-url?
|
||||
(lambda (url)
|
||||
(and (not (url-scheme url)) (not (url-params url))
|
||||
(not (url-query url)) (not (url-fragment url))
|
||||
(andmap (lambda (c) (char=? c #\space))
|
||||
(string->list (url-path url))))))
|
||||
|
||||
;; combine-url/relative : url x str -> url
|
||||
(define combine-url/relative
|
||||
(lambda (base string)
|
||||
(let ((relative (string->url string)))
|
||||
(cond
|
||||
((empty-url? base) ; Step 1
|
||||
relative)
|
||||
((empty-url? relative) ; Step 2a
|
||||
base)
|
||||
((url-scheme relative) ; Step 2b
|
||||
relative)
|
||||
(else ; Step 2c
|
||||
(set-url-scheme! relative (url-scheme base))
|
||||
(cond
|
||||
((url-host relative) ; Step 3
|
||||
relative)
|
||||
(else
|
||||
(set-url-host! relative (url-host base))
|
||||
(set-url-port! relative (url-port base)) ; Unspecified!
|
||||
(let ((rel-path (url-path relative)))
|
||||
(cond
|
||||
((and rel-path ; Step 4
|
||||
(not (string=? "" rel-path))
|
||||
(char=? #\/ (string-ref rel-path 0)))
|
||||
relative)
|
||||
((or (not rel-path) ; Step 5
|
||||
(string=? rel-path ""))
|
||||
(set-url-path! relative (url-path base))
|
||||
(or (url-params relative)
|
||||
(set-url-params! relative (url-params base)))
|
||||
(or (url-query relative)
|
||||
(set-url-query! relative (url-query base)))
|
||||
relative)
|
||||
(else ; Step 6
|
||||
(if (and (url-scheme base)
|
||||
(string=? (url-scheme base) "file"))
|
||||
|
||||
;; Important that:
|
||||
;; 1. You set-url-path! the new path into
|
||||
;; `relative'.
|
||||
;; 2. You return `relative' as the value
|
||||
;; from here without invoking
|
||||
;; `merge-and-normalize'.
|
||||
;; The variable `rel-path' contains the
|
||||
;; path portion of the relative URL.
|
||||
|
||||
(let+ ([val base-path (url-path base)]
|
||||
[val (values base name must-be-dir?)
|
||||
(split-path base-path)]
|
||||
[val base-dir (if must-be-dir? base-path base)]
|
||||
[val ind-rel-path (unixpath->path rel-path)]
|
||||
[val merged (build-path base-dir
|
||||
ind-rel-path)])
|
||||
(set-url-path! relative merged)
|
||||
relative)
|
||||
(merge-and-normalize
|
||||
(url-path base) relative))))))))))))
|
||||
|
||||
(define merge-and-normalize
|
||||
(lambda (base-path relative-url)
|
||||
(let ((rel-path (url-path relative-url)))
|
||||
(let ((base-list (string->list base-path))
|
||||
(rel-list (string->list rel-path)))
|
||||
(let*
|
||||
((joined-list
|
||||
(let loop ((base (reverse base-list)))
|
||||
(if (null? base)
|
||||
rel-list
|
||||
(if (char=? #\/ (car base))
|
||||
(append (reverse base) rel-list)
|
||||
(loop (cdr base))))))
|
||||
(grouped
|
||||
(let loop ((joined joined-list) (current '()))
|
||||
(if (null? joined)
|
||||
(list (list->string (reverse current)))
|
||||
(if (char=? #\/ (car joined))
|
||||
(cons (list->string
|
||||
(reverse (cons #\/ current)))
|
||||
(loop (cdr joined) '()))
|
||||
(loop (cdr joined)
|
||||
(cons (car joined) current))))))
|
||||
(grouped
|
||||
(let loop ((grouped grouped))
|
||||
(if (null? grouped) '()
|
||||
(if (string=? "./" (car grouped))
|
||||
(loop (cdr grouped))
|
||||
(cons (car grouped) (loop (cdr grouped)))))))
|
||||
(grouped
|
||||
(let loop ((grouped grouped))
|
||||
(if (null? grouped) '()
|
||||
(if (null? (cdr grouped))
|
||||
(if (string=? "." (car grouped)) '()
|
||||
grouped)
|
||||
(cons (car grouped) (loop (cdr grouped)))))))
|
||||
(grouped
|
||||
(let remove-loop ((grouped grouped))
|
||||
(let walk-loop ((r-pre '()) (post grouped))
|
||||
(if (null? post)
|
||||
(reverse r-pre)
|
||||
(let ((first (car post))
|
||||
(rest (cdr post)))
|
||||
(if (null? rest)
|
||||
(walk-loop (cons first r-pre) rest)
|
||||
(let ((second (car rest)))
|
||||
(if (and (not (string=? first "../"))
|
||||
(string=? second "../"))
|
||||
(remove-loop
|
||||
(append (reverse r-pre) (cddr post)))
|
||||
(walk-loop (cons first r-pre) rest)))))))))
|
||||
(grouped
|
||||
(let loop ((grouped grouped))
|
||||
(if (null? grouped) '()
|
||||
(if (null? (cdr grouped)) grouped
|
||||
(if (and (null? (cddr grouped))
|
||||
(not (string=? (car grouped) "../"))
|
||||
(string=? (cadr grouped) ".."))
|
||||
'()
|
||||
(cons (car grouped) (loop (cdr grouped)))))))))
|
||||
(set-url-path! relative-url
|
||||
(apply string-append grouped))
|
||||
relative-url)))))
|
||||
|
||||
;; call/input-url : url x (url -> in-port) x (in-port -> T)
|
||||
;; [x list (str)] -> T
|
||||
(define call/input-url
|
||||
(let ((handle-port (lambda (server->client handler)
|
||||
(dynamic-wind (lambda () 'do-nothing)
|
||||
(lambda () (handler server->client))
|
||||
(lambda () (close-input-port server->client))))))
|
||||
(case-lambda
|
||||
((url getter handler)
|
||||
(handle-port (getter url) handler))
|
||||
((url getter handler params)
|
||||
(handle-port (getter url params) handler)))))
|
||||
|
||||
(define empty-line?
|
||||
(lambda (chars)
|
||||
(or (null? chars)
|
||||
(and (memv (car chars) '(#\return #\linefeed #\tab #\space))
|
||||
(empty-line? (cdr chars))))))
|
||||
|
||||
(define extract-mime-headers-as-char-lists
|
||||
(lambda (port)
|
||||
(let headers-loop ((headers '()))
|
||||
(let char-loop ((header '()))
|
||||
(let ((c (read-char port)))
|
||||
(if (eof-object? c)
|
||||
(reverse headers) ; CHECK: INCOMPLETE MIME: SERVER BUG
|
||||
(if (char=? c #\newline)
|
||||
(if (empty-line? header)
|
||||
(reverse headers)
|
||||
(begin
|
||||
(headers-loop (cons (reverse header) headers))))
|
||||
(char-loop (cons c header)))))))))
|
||||
|
||||
;; purify-port : in-port -> list (mime-header)
|
||||
(define purify-port
|
||||
(lambda (port)
|
||||
(let ((headers-as-chars (extract-mime-headers-as-char-lists port)))
|
||||
(let header-loop ((headers headers-as-chars))
|
||||
(if (null? headers)
|
||||
'()
|
||||
(let ((header (car headers)))
|
||||
(let char-loop ((pre '()) (post header))
|
||||
(if (null? post)
|
||||
(header-loop (cdr headers))
|
||||
(if (char=? #\: (car post))
|
||||
(cons (make-mime-header
|
||||
(list->string (reverse pre))
|
||||
(list->string post))
|
||||
(header-loop (cdr headers)))
|
||||
(char-loop (cons (char-downcase (car post)) pre)
|
||||
(cdr post)))))))))))
|
||||
|
||||
(define character-set-size 256)
|
||||
|
||||
(define marker-list
|
||||
'(#\: #\; #\? #\#))
|
||||
|
||||
(define ascii-marker-list
|
||||
(map char->integer marker-list))
|
||||
|
||||
(define marker-locations
|
||||
(make-vector character-set-size))
|
||||
|
||||
(define first-position-of-marker
|
||||
(lambda (c)
|
||||
(vector-ref marker-locations (char->integer c))))
|
||||
|
||||
;; netscape/string->url : str -> url
|
||||
(define netscape/string->url
|
||||
(lambda (string)
|
||||
(let ((url (string->url string)))
|
||||
(if (url-scheme url)
|
||||
url
|
||||
(if (string=? string "")
|
||||
(url-error "Can't resolve empty string as URL")
|
||||
(begin
|
||||
(set-url-scheme! url
|
||||
(if (char=? (string-ref string 0) #\/)
|
||||
"file"
|
||||
"http"))
|
||||
url))))))
|
||||
|
||||
;; string->url : str -> url
|
||||
(define string->url
|
||||
(lambda (string)
|
||||
(let loop ((markers ascii-marker-list))
|
||||
(unless (null? markers)
|
||||
(vector-set! marker-locations (car markers) #f)
|
||||
(loop (cdr markers))))
|
||||
(let loop ((chars (string->list string)) (index 0))
|
||||
(unless (null? chars)
|
||||
(let ((first (car chars)))
|
||||
(when (memq first marker-list)
|
||||
(let ((posn (char->integer first)))
|
||||
(unless (vector-ref marker-locations posn)
|
||||
(vector-set! marker-locations posn index)))))
|
||||
(loop (cdr chars) (add1 index))))
|
||||
(let
|
||||
((first-colon (first-position-of-marker #\:))
|
||||
(first-semicolon (first-position-of-marker #\;))
|
||||
(first-question (first-position-of-marker #\?))
|
||||
(first-hash (first-position-of-marker #\#)))
|
||||
(let
|
||||
((scheme-start (and first-colon 0))
|
||||
(path-start (if first-colon (add1 first-colon) 0))
|
||||
(params-start (and first-semicolon (add1 first-semicolon)))
|
||||
(query-start (and first-question (add1 first-question)))
|
||||
(fragment-start (and first-hash (add1 first-hash))))
|
||||
(let ((total-length (string-length string)))
|
||||
(let*
|
||||
((scheme-finish (and scheme-start first-colon))
|
||||
(path-finish (if first-semicolon first-semicolon
|
||||
(if first-question first-question
|
||||
(if first-hash first-hash
|
||||
total-length))))
|
||||
(fragment-finish (and fragment-start total-length))
|
||||
(query-finish (and query-start
|
||||
(if first-hash first-hash
|
||||
total-length)))
|
||||
(params-finish (and params-start
|
||||
(if first-question first-question
|
||||
(if first-hash first-hash
|
||||
total-length)))))
|
||||
(let ((scheme (and scheme-start
|
||||
(substring string
|
||||
scheme-start scheme-finish))))
|
||||
(if (and scheme
|
||||
(string=? scheme "file"))
|
||||
(make-url
|
||||
scheme
|
||||
#f ; host
|
||||
#f ; port
|
||||
(build-path (substring string path-start total-length))
|
||||
#f ; params
|
||||
#f ; query
|
||||
#f) ; fragment
|
||||
(let-values (((host port path)
|
||||
(parse-host/port/path
|
||||
string path-start path-finish)))
|
||||
(make-url
|
||||
scheme
|
||||
host
|
||||
port
|
||||
path
|
||||
(and params-start
|
||||
(substring string params-start params-finish))
|
||||
(and query-start
|
||||
(substring string query-start query-finish))
|
||||
(and fragment-start
|
||||
(substring string fragment-start
|
||||
fragment-finish))))))))))))
|
||||
|
||||
;; parse-host/port/path : str x num x num -> (str + #f) + (num + #f) + str
|
||||
(define parse-host/port/path
|
||||
(lambda (path begin-point end-point)
|
||||
(let ((has-host? (and (>= (- end-point begin-point) 2)
|
||||
(char=? (string-ref path begin-point) #\/)
|
||||
(char=? (string-ref path (add1 begin-point))
|
||||
#\/))))
|
||||
(let ((begin-point (if has-host?
|
||||
(+ begin-point 2)
|
||||
begin-point)))
|
||||
(let loop ((index begin-point)
|
||||
(first-colon #f)
|
||||
(first-slash #f))
|
||||
(cond
|
||||
((>= index end-point)
|
||||
;; We come here only if the string has not had a /
|
||||
;; yet. This can happen in two cases:
|
||||
;; 1. The input is a relative URL, and the hostname
|
||||
;; will not be specified. In such cases, has-host?
|
||||
;; will be false.
|
||||
;; 2. The input is an absolute URL with a hostname,
|
||||
;; and the intended path is "/", but the URL is missing
|
||||
;; a "/" at the end. has-host? must be true.
|
||||
(let ((host/path (substring path begin-point end-point)))
|
||||
(if has-host?
|
||||
(values host/path #f "/")
|
||||
(values #f #f host/path))))
|
||||
((char=? #\: (string-ref path index))
|
||||
(loop (add1 index) (or first-colon index) first-slash))
|
||||
((char=? #\/ (string-ref path index))
|
||||
(if first-colon
|
||||
(values
|
||||
(substring path begin-point first-colon)
|
||||
(string->number (substring path (add1 first-colon)
|
||||
index))
|
||||
(substring path index end-point))
|
||||
(if has-host?
|
||||
(values
|
||||
(substring path begin-point index)
|
||||
#f
|
||||
(substring path index end-point))
|
||||
(values
|
||||
#f
|
||||
#f
|
||||
(substring path begin-point end-point)))))
|
||||
(else
|
||||
(loop (add1 index) first-colon first-slash))))))))
|
||||
|
||||
)
|
||||
|
||||
|
|
@ -1,18 +0,0 @@
|
|||
(require-library "macro.ss")
|
||||
(require-library "files.ss")
|
||||
|
||||
(define-signature mzlib:url^
|
||||
((struct url (scheme host port path params query fragment))
|
||||
(struct mime-header (name value))
|
||||
unixpath->path
|
||||
get-pure-port ; url [x list (str)] -> in-port
|
||||
get-impure-port ; url [x list (str)] -> in-port
|
||||
display-pure-port ; in-port -> ()
|
||||
purify-port ; in-port -> list (mime-header)
|
||||
netscape/string->url ; (string -> url)
|
||||
string->url ; str -> url
|
||||
url->string
|
||||
call/input-url ; url x (url -> in-port) x
|
||||
; (in-port -> T)
|
||||
; [x list (str)] -> T
|
||||
combine-url/relative)) ; url x str -> url
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
(require-library "refer.ss")
|
||||
(require-library "urls.ss" "net")
|
||||
|
||||
(define mzlib:url@
|
||||
(require-library-unit/sig "urlr.ss" "net"))
|
||||
|
|
@ -1,230 +0,0 @@
|
|||
; Time-stamp: <98/05/08 22:29:05 shriram>
|
||||
|
||||
; * Need to make write-holdings-to-file set permissions appropriately.
|
||||
; * add-{stock,fund} should check if the entry already exists.
|
||||
; * Allow update of holdings.
|
||||
; * Print numbers in columns.
|
||||
; * Improve output quality and media.
|
||||
; * Enable queries on individual holdings.
|
||||
|
||||
;; Format of RC file:
|
||||
;; current-seconds (when file was last written)
|
||||
;; ((entity quantity price) ...)
|
||||
;; <eof>
|
||||
;; where entity = (stock "...") or (fund "...")
|
||||
|
||||
(require-library "match.ss")
|
||||
(require-library "date.ss")
|
||||
|
||||
(require-library "qq.ss" "quasiquote")
|
||||
|
||||
(define rc-file "~/.qqrc")
|
||||
|
||||
;; entity : entity
|
||||
;; quantity : num
|
||||
;; price : num
|
||||
|
||||
(define-struct holding (entity quantity price))
|
||||
|
||||
;; raw-holding->holding :
|
||||
;; raw-holding -> holding
|
||||
|
||||
(define raw-holding->holding
|
||||
(lambda (rh)
|
||||
(match rh
|
||||
((('stock name) quantity price)
|
||||
(make-holding (stock name) quantity price))
|
||||
((('fund name) quantity price)
|
||||
(make-holding (fund name) quantity price))
|
||||
(else (error 'qq-client "~s is an invalid entry in the database" rh)))))
|
||||
|
||||
;; holding->raw-holding :
|
||||
;; holding -> raw-holding
|
||||
|
||||
(define holding->raw-holding
|
||||
(lambda (h)
|
||||
(list
|
||||
(let ((entity (holding-entity h)))
|
||||
(cond
|
||||
((stock? entity) `(stock ,(entity-name entity)))
|
||||
((fund? entity) `(fund ,(entity-name entity)))
|
||||
(else
|
||||
(error 'qq-client "~s is not a valid entity" entity))))
|
||||
(holding-quantity h)
|
||||
(holding-price h))))
|
||||
|
||||
;; write-holdings-to-file :
|
||||
;; list (holding) -> ()
|
||||
|
||||
(define write-holdings-to-file
|
||||
(lambda (holdings)
|
||||
(let ((p (open-output-file rc-file 'replace)))
|
||||
(display "; -*- Scheme -*-" p)
|
||||
(newline p) (newline p)
|
||||
(display "; Do not edit directly: please use QuasiQuote clients!" p)
|
||||
(newline p) (newline p)
|
||||
(write (current-seconds) p)
|
||||
(newline p) (newline p)
|
||||
(write (map holding->raw-holding holdings) p)
|
||||
(newline p)
|
||||
(close-output-port p))))
|
||||
|
||||
;; read-holdings-from-file :
|
||||
;; () -> (seconds + #f) x list (holding)
|
||||
|
||||
(define read-holdings-from-file
|
||||
(lambda ()
|
||||
(with-handlers ((exn:i/o:filesystem? (lambda (exn)
|
||||
(values #f null))))
|
||||
(let ((p (open-input-file rc-file)))
|
||||
(values (read p)
|
||||
(map raw-holding->holding
|
||||
(read p)))))))
|
||||
|
||||
;; update-holdings :
|
||||
;; list (holding) -> list (holding)
|
||||
|
||||
(define update-holdings
|
||||
(lambda (holdings)
|
||||
(map (lambda (h)
|
||||
(let ((entity (holding-entity h)))
|
||||
(let ((new-value (get-quote entity)))
|
||||
(make-holding entity (holding-quantity h) new-value))))
|
||||
holdings)))
|
||||
|
||||
;; changed-positions :
|
||||
;; list (holding) x list (holding) ->
|
||||
;; list (holding . num) x list (holding . num) x list (holding)
|
||||
|
||||
(define changed-positions
|
||||
(lambda (old-in new-in)
|
||||
(let loop ((old old-in) (new new-in)
|
||||
(increases null) (decreases null) (stays null))
|
||||
(if (and (null? old) (null? new))
|
||||
(values increases decreases stays)
|
||||
(if (or (null? old) (null? new))
|
||||
(error 'qq-client "~s and ~s cannot be compared for changes"
|
||||
old-in new-in)
|
||||
(let ((first-old (car old)) (first-new (car new)))
|
||||
(if (string=? (entity-name (holding-entity first-old))
|
||||
(entity-name (holding-entity first-new)))
|
||||
(let* ((price-old (holding-price first-old))
|
||||
(price-new (holding-price first-new))
|
||||
(difference (- price-new price-old)))
|
||||
(cond
|
||||
((= price-old price-new)
|
||||
(loop (cdr old) (cdr new)
|
||||
increases
|
||||
decreases
|
||||
(cons first-new stays)))
|
||||
((< price-old price-new)
|
||||
(loop (cdr old) (cdr new)
|
||||
(cons (cons first-new difference) increases)
|
||||
decreases
|
||||
stays))
|
||||
(else
|
||||
(loop (cdr old) (cdr new)
|
||||
increases
|
||||
(cons (cons first-new difference) decreases)
|
||||
stays))))
|
||||
(error 'qq-client "~s and ~s are in the same position"
|
||||
first-old first-new))))))))
|
||||
|
||||
;; total-value :
|
||||
;; list (holding) -> num
|
||||
|
||||
(define total-value
|
||||
(lambda (holdings)
|
||||
(apply +
|
||||
(map (lambda (h)
|
||||
(* (holding-quantity h) (holding-price h)))
|
||||
holdings))))
|
||||
|
||||
;; print-position-changes :
|
||||
;; list (holding . num) x list (holding . num) x list (holding) -> ()
|
||||
|
||||
(define print-position-changes
|
||||
(lambda (increases decreases stays)
|
||||
(define print-entry/change
|
||||
(lambda (holding change)
|
||||
(printf "~a ~a ~a~a~n"
|
||||
(entity-name (holding-entity holding))
|
||||
(holding-price holding)
|
||||
(if (> change 0) "+" "-")
|
||||
(abs change))))
|
||||
(define print-change
|
||||
(lambda (banner changes)
|
||||
(unless (null? changes)
|
||||
(printf "~a:~n" banner))
|
||||
(for-each (lambda (h+delta)
|
||||
(print-entry/change (car h+delta) (cdr h+delta)))
|
||||
changes)
|
||||
(newline)))
|
||||
(print-change "Increases" increases)
|
||||
(print-change "Decreases" decreases)))
|
||||
|
||||
;; print-statement :
|
||||
;; () -> ()
|
||||
|
||||
(define print-statement
|
||||
(lambda ()
|
||||
(let-values (((old-time old-holdings)
|
||||
(read-holdings-from-file)))
|
||||
(let ((new-holdings (update-holdings old-holdings)))
|
||||
(when old-time
|
||||
(printf "Changes are since ~a~n~n"
|
||||
(date->string (seconds->date old-time))))
|
||||
(let-values (((increases decreases stays)
|
||||
(changed-positions old-holdings new-holdings)))
|
||||
(print-position-changes increases decreases stays))
|
||||
(let ((old-total (total-value old-holdings))
|
||||
(new-total (total-value new-holdings)))
|
||||
(printf "Total change: ~a~nTotal value: ~a~n"
|
||||
(- new-total old-total) new-total))
|
||||
(write-holdings-to-file new-holdings)))))
|
||||
|
||||
;; create-holding :
|
||||
;; (str -> entity) -> str x num -> holding
|
||||
|
||||
(define create-holding
|
||||
(lambda (maker)
|
||||
(lambda (name quantity)
|
||||
(let ((entity (maker name)))
|
||||
(let ((price (get-quote entity)))
|
||||
(make-holding entity quantity price))))))
|
||||
|
||||
;; create-holding/stock :
|
||||
;; str x num -> holding
|
||||
|
||||
(define create-holding/stock
|
||||
(create-holding stock))
|
||||
|
||||
;; create-holding/fund :
|
||||
;; str x num -> holding
|
||||
|
||||
(define create-holding/fund
|
||||
(create-holding fund))
|
||||
|
||||
;; add-holding :
|
||||
;; (str x num -> holding) -> x str x num -> ()
|
||||
|
||||
(define add-holding
|
||||
(lambda (maker)
|
||||
(lambda (name quantity)
|
||||
(let-values (((old-time old-holdings)
|
||||
(read-holdings-from-file)))
|
||||
(write-holdings-to-file
|
||||
(cons (maker name quantity)
|
||||
old-holdings))))))
|
||||
|
||||
;; add-stock :
|
||||
;; str x num -> ()
|
||||
|
||||
(define add-stock
|
||||
(add-holding create-holding/stock))
|
||||
|
||||
;; add-fund :
|
||||
;; str x num -> ()
|
||||
|
||||
(define add-fund
|
||||
(add-holding create-holding/fund))
|
||||
|
|
@ -1,22 +0,0 @@
|
|||
(require-library "urls.ss" "net")
|
||||
(require-library "refer.ss")
|
||||
(require-library "coreu.ss")
|
||||
(require-library "qqu.ss" "quasiquote")
|
||||
|
||||
(define quasiquote:program@
|
||||
(compound-unit/sig
|
||||
(import)
|
||||
(link
|
||||
(MZLIB-CORE : mzlib:core^
|
||||
(mzlib:core@))
|
||||
(URL : mzlib:url^
|
||||
((require-library-unit/sig "urlr.ss" "net")
|
||||
(MZLIB-CORE file)))
|
||||
(INTERFACE : quasiquote:graphical-interface^
|
||||
(quasiquote:graphical-interface@))
|
||||
(QUOTESTER : quasiquote:quotester^
|
||||
(quasiquote:quotester@ INTERFACE URL)))
|
||||
(export
|
||||
(open QUOTESTER))))
|
||||
|
||||
(define-values/invoke-unit/sig quasiquote:quotester^ quasiquote:program@)
|
||||
|
|
@ -1,21 +0,0 @@
|
|||
(unit/sig quasiquote:graphical-interface^
|
||||
(import)
|
||||
|
||||
(define display-image-stream
|
||||
(lambda (input-port stock-name)
|
||||
(let ((tmp-file-name
|
||||
(build-path (current-directory)
|
||||
(string-append stock-name "."
|
||||
(number->string (current-seconds))
|
||||
".gif"))))
|
||||
(let ((p (open-output-file tmp-file-name)))
|
||||
(let loop ()
|
||||
(let ((c (read-char input-port)))
|
||||
(unless (eof-object? c)
|
||||
(display c p)
|
||||
(loop))))
|
||||
(close-output-port p)
|
||||
(close-input-port input-port)
|
||||
(process (string-append "xv " tmp-file-name))))))
|
||||
|
||||
)
|
||||
|
|
@ -1,98 +0,0 @@
|
|||
(unit/sig quasiquote:quotester^
|
||||
(import
|
||||
quasiquote:graphical-interface^
|
||||
(url : mzlib:url^))
|
||||
|
||||
(define-struct entity (name))
|
||||
(define-struct (stock struct:entity) ())
|
||||
(define-struct (fund struct:entity) ())
|
||||
|
||||
(define get-chart
|
||||
(lambda (entity)
|
||||
(define base-directory-for-stocks "/sm/pg/")
|
||||
;; Rule: append <capital initial of entity>/<entity>.gif
|
||||
(define base-directory-for-funds "/sm/trmfg/")
|
||||
;; Rule: append <capital initial of entity>/<entity>.gif
|
||||
(define handle-processing
|
||||
(lambda (base-dir)
|
||||
(let ((s (entity-name entity)))
|
||||
(display-image-stream
|
||||
(url:get-pure-port
|
||||
(url:make-url "http" "www.stockmaster.com" #f
|
||||
(string-append base-dir "/"
|
||||
(string (string-ref s 0))
|
||||
"/" s ".gif")
|
||||
#f #f #f))
|
||||
s))))
|
||||
(cond
|
||||
((stock? entity)
|
||||
(handle-processing base-directory-for-stocks))
|
||||
((fund? entity)
|
||||
(handle-processing base-directory-for-funds))
|
||||
(else
|
||||
(error 'get-chart
|
||||
"~s is not a stock or fund" entity)))))
|
||||
|
||||
;; http://www.stocksmart.com/ows-bin/owa/sq.returnPrice?symbol=<SYMBOL>
|
||||
;; (regexp "<TD ALIGN=\"RIGHT\">\\$(.+)</TD>")
|
||||
;; no longer works -- advantage is it provided ratios instead of decimals
|
||||
|
||||
;; http://quote.yahoo.com/q?s=<SYMBOL>&d=v1
|
||||
;; provides some quotes as ratios -- hence the second regexp
|
||||
|
||||
(define extract-quote-amount
|
||||
(let ((quote-pattern (regexp "<td nowrap><b>(.+)</b></td>"))
|
||||
(ratio-pattern (regexp "<sup>([0-9]+)</sup>/<sub>([0-9]+)</sub>")))
|
||||
(lambda (port symbol)
|
||||
(let loop ()
|
||||
(let ((line (read-line port)))
|
||||
(if (eof-object? line)
|
||||
(error 'get-quote
|
||||
"No quote found for ~s" (entity-name symbol))
|
||||
(let ((matched (regexp-match quote-pattern line)))
|
||||
(if matched
|
||||
(let ((value
|
||||
(let (($string (cadr matched)))
|
||||
(let ((p (open-input-string $string)))
|
||||
(let loop ((sum 0))
|
||||
(let ((r (read p)))
|
||||
(if (eof-object? r)
|
||||
sum
|
||||
(loop (+ (if (number? r)
|
||||
r
|
||||
(let ((ratio-matched
|
||||
(regexp-match
|
||||
ratio-pattern
|
||||
(symbol->string r))))
|
||||
(if ratio-matched
|
||||
(/ (string->number
|
||||
(cadr ratio-matched))
|
||||
(string->number
|
||||
(caddr ratio-matched)))
|
||||
(error 'get-quote
|
||||
"Unrecognized quote ~s"
|
||||
r))))
|
||||
sum)))))))))
|
||||
;; out of courtesy to the server, we'll read it all
|
||||
(let finish-loop ()
|
||||
(let ((line (read-line port)))
|
||||
(unless (eof-object? line)
|
||||
(finish-loop))))
|
||||
value)
|
||||
(loop)))))))))
|
||||
|
||||
(define get-quote
|
||||
(lambda (symbol)
|
||||
(extract-quote-amount
|
||||
(url:get-pure-port
|
||||
(url:make-url "http" "quote.yahoo.com" #f
|
||||
"/q" ;; leading slash essential
|
||||
#f
|
||||
(string-append "s=" (entity-name symbol) "&d=v1")
|
||||
#f))
|
||||
symbol)))
|
||||
|
||||
(define stock make-stock)
|
||||
(define fund make-fund)
|
||||
|
||||
)
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
(define-signature quasiquote:graphical-interface^
|
||||
(display-image-stream))
|
||||
|
||||
(define-signature quasiquote:quotester^
|
||||
(get-chart
|
||||
get-quote
|
||||
(struct entity (name))
|
||||
(struct stock ())
|
||||
(struct fund ())
|
||||
stock
|
||||
fund))
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
(require-library "refer.ss")
|
||||
(require-library "qqs.ss" "quasiquote")
|
||||
|
||||
(define quasiquote:quotester@
|
||||
(require-library-unit/sig "qqr.ss" "quasiquote"))
|
||||
|
||||
(define quasiquote:graphical-interface@
|
||||
(require-library-unit/sig "qqguir.ss" "quasiquote"))
|
||||
|
|
@ -1,54 +0,0 @@
|
|||
|
||||
The _readline_ collection (not to be confused with MzScheme's
|
||||
`read-line' procedure) provides glue for using GNU's readline library
|
||||
with the MzScheme read-eval-print-loop. It has been tested under Linux
|
||||
(various flavors), FreeBSD, and Solaris.
|
||||
|
||||
To use readline, you must be able to compile the "mzrl.c" file to
|
||||
produce a MzScheme extension, which requires a C compiler. The
|
||||
"mzmake.ss" program in the "readline" library attempts to compile it
|
||||
for you, and the collection installer runs "mzmake.ss". Thus, if the
|
||||
installation succeeds, you can use the readline library right
|
||||
away. Otherwise, you may have to modified "mzmake.ss" to get it to
|
||||
work.
|
||||
|
||||
|
||||
Normal use of readline
|
||||
----------------------
|
||||
|
||||
The _rep.ss_ library installs a readline-based function for the
|
||||
prompt-and-read part of MzScheme's read-eval-print loop.
|
||||
|
||||
I put the following in my ~/.mzschemerc so that MzScheme always starts
|
||||
with readline support:
|
||||
|
||||
(require-library "rep.ss" "readline")
|
||||
|
||||
The readline history is stored across invocations in ~/.mzrl.history,
|
||||
assuming MzScheme exits normally.
|
||||
|
||||
|
||||
Direct bindings for readline hackers
|
||||
------------------------------------
|
||||
|
||||
The _readline.ss_ library provides two functions:
|
||||
|
||||
> (readline prompt-string) - prints the given prompt string and reads
|
||||
an S-expression.
|
||||
|
||||
> (add-history s) - adds the given string to the readline history,
|
||||
which is accessible to the user via the up-arrow key
|
||||
|
||||
|
||||
Known Bugs
|
||||
----------
|
||||
|
||||
Hitting ctl-C more than once tends to make either readline or MzScheme
|
||||
crash (I'm not sure which one).
|
||||
|
||||
|
||||
|
||||
mflatt@cs.utah.edu
|
||||
|
||||
Note to self: pack with
|
||||
(pack "readline.plt" "readline" '("collects/readline") '(("readline")))
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
(lambda (request failure-thunk)
|
||||
(case request
|
||||
[(name) "readline"]
|
||||
[(install-collection)
|
||||
(lambda (path)
|
||||
(parameterize ([current-namespace (make-namespace)]
|
||||
[current-directory (build-path path "collects" "readline")])
|
||||
(global-defined-value 'argv #())
|
||||
(load "mzmake.ss")))]
|
||||
[else (failure-thunk)]))
|
||||
|
|
@ -1,116 +0,0 @@
|
|||
#!/bin/sh -f
|
||||
string=? ; if [ "$PLTHOME" = "" ] ; then
|
||||
string=? ; echo Please define PLTHOME
|
||||
string=? ; exit -1
|
||||
string=? ; fi
|
||||
string=? ; exec ${PLTHOME}/bin/mzscheme -qr $0 "$@"
|
||||
|
||||
;;; This program attempts to compile and link mzrl.c.
|
||||
;;; See doc.txt for more information.
|
||||
|
||||
(define mach-id (string->symbol (system-library-subpath)))
|
||||
|
||||
;; Is the readline library in /usr/local/gnu ?
|
||||
|
||||
;; We look for the readline library and includes in the
|
||||
;; following places:
|
||||
(define search-path
|
||||
(list "/usr"
|
||||
"/usr/local/gnu"
|
||||
;; Hack for the author's convenience:
|
||||
(format "/home/mflatt/proj/readline-2.1/~a" mach-id)))
|
||||
|
||||
(define rl-path
|
||||
(ormap (lambda (x)
|
||||
(and (directory-exists? (build-path x "include" "readline"))
|
||||
(or (file-exists? (build-path x "lib" "libreadline.a"))
|
||||
(file-exists? (build-path x "lib" "libreadline.so")))
|
||||
x))
|
||||
search-path))
|
||||
|
||||
(unless rl-path
|
||||
(error 'readline-installer
|
||||
"can't find readline include files and/or library; try editing `search-path' in mzmake.ss"))
|
||||
|
||||
(require-library "make.ss" "make")
|
||||
(require-library "link.ss" "dynext")
|
||||
(require-library "compile.ss" "dynext")
|
||||
(require-library "file.ss" "dynext")
|
||||
|
||||
(require-library "file.ss")
|
||||
(require-library "functio.ss")
|
||||
|
||||
(make-print-checking #f)
|
||||
|
||||
;; Used as make dependencies:
|
||||
(define header (build-path (collection-path "mzscheme" "include") "scheme.h"))
|
||||
(define version-header (build-path (collection-path "mzscheme" "include") "schvers.h"))
|
||||
|
||||
(define dir (build-path "compiled" "native" (system-library-subpath)))
|
||||
(define mzrl.so (build-path dir (append-extension-suffix "mzrl")))
|
||||
(define mzrl.o (build-path dir (append-object-suffix "mzrl")))
|
||||
|
||||
;; Function used to add a command-line flag:
|
||||
(define (add-flags fp flags)
|
||||
(fp (append (fp) flags)))
|
||||
|
||||
;; Add -I to compiler command-line
|
||||
(add-flags current-extension-compiler-flags
|
||||
(list (format "-I~a/include" rl-path)))
|
||||
|
||||
;; More platform-specific compiler flags.
|
||||
(case mach-id
|
||||
[(rs6k-aix)
|
||||
(add-flags current-extension-compiler-flags
|
||||
(list "-DNEEDS_SELECT_H"))]
|
||||
[else (void)])
|
||||
|
||||
;; If we don't have a .so file, we need to make the linker
|
||||
;; use the whole archive:
|
||||
(when (not (file-exists? (build-path rl-path "lib" "libreadline.so")))
|
||||
(case mach-id
|
||||
[(sparc-solaris i386-solaris)
|
||||
(add-flags current-extension-linker-flags
|
||||
(list "-u" "rl_readline_name"))]
|
||||
[(i386-linux i386-freebsd)
|
||||
(add-flags current-extension-linker-flags
|
||||
(list "--whole-archive"))]
|
||||
[else (fpritnf (current-error-port)
|
||||
"mzmake.ss Warning: trying to use .a library, but don't know how to force inclusion;~
|
||||
~n result may have undefined references~n")]))
|
||||
|
||||
;; Add -L and -l for readline:
|
||||
(add-flags current-extension-linker-flags
|
||||
(list (format "-L~a/lib" rl-path)
|
||||
"-lreadline"))
|
||||
|
||||
; More platform-specific linker flags.
|
||||
(case mach-id
|
||||
[(sparc-solaris i386-solaris)
|
||||
(add-flags current-extension-linker-flags
|
||||
(list "-ltermcap"))]
|
||||
[(rs6k-aix)
|
||||
(add-flags current-extension-linker-flags
|
||||
(list "-lc"))]
|
||||
[else (void)])
|
||||
|
||||
;; Add the -lcurses flag:
|
||||
(add-flags current-extension-linker-flags (list "-lcurses"))
|
||||
|
||||
(define (delete/continue x)
|
||||
(with-handlers ([(lambda (x) #t) void])
|
||||
(delete-file x)))
|
||||
|
||||
(make
|
||||
((mzrl.so (mzrl.o dir)
|
||||
(link-extension #f (list mzrl.o) mzrl.so))
|
||||
|
||||
(mzrl.o ("mzrl.c" header version-header dir)
|
||||
(compile-extension #f "mzrl.c" mzrl.o ()))
|
||||
|
||||
("clean" () (begin (delete/continue mzrl.o) (delete/continue mzrl.so)))
|
||||
|
||||
(dir ()
|
||||
(make-directory* dir)))
|
||||
|
||||
argv)
|
||||
|
|
@ -1,94 +0,0 @@
|
|||
|
||||
#include "escheme.h"
|
||||
#include <sys/types.h>
|
||||
#include <sys/time.h>
|
||||
#include <unistd.h>
|
||||
#ifdef NEEDS_SELECT_H
|
||||
# include <sys/select.h>
|
||||
#endif
|
||||
#include <readline/readline.h>
|
||||
|
||||
/* For pre-102 compatibility: */
|
||||
#ifndef MZ_DECL_VAR_REG
|
||||
# define MZ_DECL_VAR_REG(x) /* empty */
|
||||
# define MZ_VAR_REG(p, x) /* empty */
|
||||
# define MZ_CWVR(x) x
|
||||
#endif
|
||||
|
||||
extern Function *rl_event_hook;
|
||||
|
||||
Scheme_Object *do_readline(int argc, Scheme_Object **argv)
|
||||
{
|
||||
char *s;
|
||||
Scheme_Object *o;
|
||||
|
||||
if (!SCHEME_STRINGP(argv[0]))
|
||||
scheme_wrong_type("readline", "string", 0, argc, argv);
|
||||
|
||||
s = readline(SCHEME_STR_VAL(argv[0]));
|
||||
if (!s)
|
||||
return scheme_eof;
|
||||
|
||||
o = scheme_make_string(s);
|
||||
|
||||
free(s);
|
||||
|
||||
return o;
|
||||
}
|
||||
|
||||
Scheme_Object *do_add_history(int argc, Scheme_Object **argv)
|
||||
{
|
||||
char *s;
|
||||
Scheme_Object *o;
|
||||
|
||||
if (!SCHEME_STRINGP(argv[0]))
|
||||
scheme_wrong_type("add-history", "string", 0, argc, argv);
|
||||
|
||||
add_history(SCHEME_STR_VAL(argv[0]));
|
||||
|
||||
return scheme_void;
|
||||
}
|
||||
|
||||
static int check(Scheme_Object *x)
|
||||
{
|
||||
fd_set fd;
|
||||
struct timeval time = {0, 0};
|
||||
|
||||
FD_ZERO(&fd);
|
||||
FD_SET(0, &fd);
|
||||
return select(1, &fd, NULL, NULL, &time);
|
||||
}
|
||||
|
||||
static void set_fd_wait(Scheme_Object *x, void *fd)
|
||||
{
|
||||
MZ_FD_SET(0, (fd_set *)fd);
|
||||
}
|
||||
|
||||
static int block(void)
|
||||
{
|
||||
scheme_block_until(check, set_fd_wait, scheme_void, 0.0);
|
||||
return 0;
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_reload(Scheme_Env *env)
|
||||
{
|
||||
Scheme_Object *a[2];
|
||||
MZ_DECL_VAR_REG(2);
|
||||
MZ_VAR_REG(0, a[0]);
|
||||
MZ_VAR_REG(1, a[1]);
|
||||
|
||||
a[0] = MZ_CWVR(scheme_make_prim_w_arity(do_readline, "readline", 1, 1));
|
||||
a[1] = MZ_CWVR(scheme_make_prim_w_arity(do_add_history, "add-history", 1, 1));
|
||||
|
||||
return MZ_CWVR(scheme_values(2, a));
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_initialize(Scheme_Env *env)
|
||||
{
|
||||
|
||||
rl_readline_name = "mzscheme";
|
||||
|
||||
rl_event_hook = block;
|
||||
|
||||
return scheme_reload(env);
|
||||
}
|
||||
|
|
@ -1,61 +0,0 @@
|
|||
|
||||
(let*-values ([(.history) "~/.mzrl.history"]
|
||||
[(MAX-HISTORY) 100]
|
||||
[(readline add-history) (require-library "readline.ss" "readline")]
|
||||
[(leftovers) null]
|
||||
[(local-history)
|
||||
(with-handlers ([void (lambda (exn) null)])
|
||||
(with-input-from-file .history
|
||||
(lambda () (read))))]
|
||||
[(do-readline)
|
||||
(lambda (p)
|
||||
(let ([s (readline p)])
|
||||
(when (string? s)
|
||||
(add-history s)
|
||||
(if (= (length local-history) MAX-HISTORY)
|
||||
(set! local-history (cdr local-history)))
|
||||
(set! local-history (append local-history (list s))))
|
||||
s))]
|
||||
[(save-history)
|
||||
(lambda ()
|
||||
(with-handlers ([void void])
|
||||
(with-output-to-file .history
|
||||
(lambda () (write local-history))
|
||||
'truncate)))])
|
||||
(exit-handler (let ([old (exit-handler)])
|
||||
(lambda (v)
|
||||
(save-history)
|
||||
(old v))))
|
||||
(for-each add-history local-history)
|
||||
(let ([prompt-read-using-readline
|
||||
(lambda (get-prompt)
|
||||
(if (pair? leftovers)
|
||||
(begin0
|
||||
(car leftovers)
|
||||
(set! leftovers (cdr leftovers)))
|
||||
(let big-loop ()
|
||||
(let loop ([s (do-readline (get-prompt 0))][next-pos 1])
|
||||
(if (eof-object? s)
|
||||
(begin
|
||||
(save-history)
|
||||
s)
|
||||
(with-handlers ([exn:read:eof?
|
||||
(lambda (exn)
|
||||
(loop (string-append
|
||||
s
|
||||
(string #\newline)
|
||||
(do-readline (get-prompt next-pos)))
|
||||
(add1 next-pos)))])
|
||||
(let* ([p (open-input-string s)]
|
||||
[rs (let loop ()
|
||||
(let ([r (read p)])
|
||||
(if (eof-object? r)
|
||||
null
|
||||
(cons r (loop)))))])
|
||||
(if (null? rs)
|
||||
(big-loop)
|
||||
(begin0
|
||||
(car rs)
|
||||
(set! leftovers (cdr rs)))))))))))])
|
||||
prompt-read-using-readline))
|
||||
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
|
||||
(load-relative-extension (build-path "compiled" "native" (system-library-subpath) "mzrl.so"))
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
|
||||
(current-prompt-read
|
||||
(let ([read (require-library "pread.ss" "readline")]
|
||||
[orig-read (current-prompt-read)]
|
||||
[orig-input (current-input-port)])
|
||||
(lambda ()
|
||||
(if (eq? (current-input-port) orig-input)
|
||||
(read (lambda (n) (if (zero? n) "> " " ")))
|
||||
(orig-read)))))
|
||||
|
||||
|
|
@ -1,289 +0,0 @@
|
|||
|
||||
_Setup PLT_ or _setup-plt_: Collection Setup and Unpacking
|
||||
==========================================================
|
||||
|
||||
The Setup PLT executable (bin/setup-plt for Unix) performs two
|
||||
services:
|
||||
|
||||
* Compiling and setting up all collections: When Setup PLT is run
|
||||
without any arguments, it finds all of the current collections
|
||||
(using the PLTHOME and PLTCOLLECTS environment variable)
|
||||
and compiles all collections with an info.ss library that
|
||||
indicates how the collection is compiled (see the
|
||||
--collection-zos flag for mzc).
|
||||
|
||||
The --clean (or -c) flag to Setup PLT causes it to delete
|
||||
all existing .zo and extension files, thus ensuring a clean
|
||||
build from the source files. (Exactly which files are deleted
|
||||
is controlled by the info.ss file. See below for more info.)
|
||||
|
||||
The -l flag takes one or more collection names and restricts
|
||||
Setup PLT's action to those collections.
|
||||
|
||||
In addition to compilation, a collection's info.ss library
|
||||
can specify executables to be installed in the plt directory
|
||||
(plt/bin under Unix) or other installation actions.
|
||||
|
||||
* Unpacking _.plt_ files: A .plt file is a platform-indepedent
|
||||
distribution archive for MzScheme- and MrEd-based software.
|
||||
When one or more file names are provided as the command line
|
||||
arguments to Setup PLT, the files contained in the .plt
|
||||
archive are unpacked (according to specifications embedded in
|
||||
the .plt file; see below) and only the collections specified
|
||||
by the plt file are compiled and setup (they are setup as if
|
||||
the "-c" or "--clean" flag had been passed to setup plt)
|
||||
|
||||
Compiling and Setting Up Collections
|
||||
------------------------------------
|
||||
|
||||
Setup PLT attempts to compile and set up any collection that:
|
||||
|
||||
* has an info.ss library;
|
||||
|
||||
* is a top-level collection (not a sub-collection; top-level
|
||||
collections can specify subcollections to be compiled and
|
||||
set up with the `compile-subcollections' info.ss field);
|
||||
and
|
||||
|
||||
* has the 'name info.ss field.
|
||||
|
||||
Collections meeting this criteria are compiled using the
|
||||
`compile-collection-zos' procedure described above. If the -e or
|
||||
--extension flag is specified, then the collections are also compiled
|
||||
using the `compile-collection-extension' procedure described above.
|
||||
|
||||
Additional info.ss fields trigger additional setup actions:
|
||||
|
||||
> 'mzscheme-launcher-names - a list of executable names to be
|
||||
installed in plt (or plt/bin) to run MzScheme programs implemented
|
||||
by the collection. A parallel list of library names must be
|
||||
provided by `mzscheme-launcher-libraries'. For each name, a
|
||||
launching executable is set up using the launcher collection's
|
||||
`install-mzscheme-program-launcher'. If the executable already
|
||||
exists, no action is taken.
|
||||
|
||||
> 'mzscheme-launcher-libraries - a list of library names in
|
||||
parallel to `mzscheme-launcher-names'.
|
||||
|
||||
> 'mred-launcher-names - a list of executable names to be installed
|
||||
in plt (or plt/bin) to run MrEd programs implemented by the
|
||||
collection. A parallel list of library names must be provided by
|
||||
`mred-launcher-libraries'. For each name, a launching executable is
|
||||
set up using the launcher collection's
|
||||
`install-mred-program-launcher'. If the executable already exists,
|
||||
no action is taken.
|
||||
|
||||
> 'mred-launcher-libraries - a list of library names in
|
||||
parallel to `mred-launcher-names'.
|
||||
|
||||
> 'install-collection - a procedure that accepts a directory path
|
||||
argument (the path to the collection) and performs
|
||||
collection-specific installation work. This procedure should avoid
|
||||
unnecessary work in the case that it is called multiple times for
|
||||
the same installation.
|
||||
|
||||
> 'clean - a list of pathnames to be deleted when the --clean or
|
||||
-c flag is passed to setup-plt. The pathnames must be relative to
|
||||
the collection. If the any path names a directory, each of the
|
||||
files in the directory are deleted but none of the subdirectories of that
|
||||
directory are checked. If the path names a file,
|
||||
the file is deleted. The default, if this flag is not specified, is
|
||||
to delete all files in the compiled subdirectory.
|
||||
and all of the files in the architecture-specific subdirectory of
|
||||
the compiled directory, for the architecture that setup-plt
|
||||
is running under.
|
||||
|
||||
|
||||
Unpacking .plt Distribution Archives
|
||||
------------------------------------
|
||||
|
||||
The extension ".plt" is not required for a distribution archive; this
|
||||
convention merely helps users identify the purpose of a distribution
|
||||
file.
|
||||
|
||||
The raw format of a distribution file is described below. This format
|
||||
is uncompressed and sensitive to communication modes (text
|
||||
vs. binary), so the distribution format is derived from the raw format
|
||||
by first compressing the file using gzip, then encoding the gzipped
|
||||
file with the MIME base64 standard (which relies only the characters
|
||||
A-Z, a-z, 0-9, +, /, and =; all other characters are ignored when
|
||||
a base64-encoded file is decoded).
|
||||
|
||||
The raw format is
|
||||
|
||||
* "PLT" are the first three characters.
|
||||
|
||||
* An info.ss-like procedure that takes a symbol and a failure thunk
|
||||
and returns information about archive for recognized symbols. The
|
||||
two required info fields are:
|
||||
|
||||
+ 'name - a human-readable string describing the archive's
|
||||
contents. This name is used only for printing messages to the
|
||||
user during unpacking.
|
||||
|
||||
+ 'unpacker - a symbol indicating the expected unpacking
|
||||
environment. Currently, the only allowed value is 'mzscheme.
|
||||
|
||||
The procedure is extracted from the archive using MzScheme's
|
||||
`read' and `eval' procedures.
|
||||
|
||||
* An unsigned unit that drives the unpacking process. The unit accepts two
|
||||
imports: a path string for the plt directory and an `unmztar'
|
||||
procedure. The remainder of the unpacking process consists of invoking
|
||||
ths unit. It is expected that the unit will call `unmztar' procedure to
|
||||
unpack directories and files that are defined in the input archive afer
|
||||
this unit. The result of invoking the unit must be a list of collection
|
||||
paths (where each collection path is a list of strings); once the
|
||||
archive is unpacked, Setup PLT will compile and setup the specified
|
||||
collections, as if it was invoked with the "-c" option, so the
|
||||
"compiled" directories will be deleted.
|
||||
|
||||
The `unmztar' procedure takes one argument: a filter
|
||||
procedure. The filter procedure is called for each directory and
|
||||
file to be unpacked. It is called with three arguments:
|
||||
|
||||
+ 'dir, 'file, 'file-replace - indicates whether the item to be
|
||||
unpacked is a directory, a file, or a file to be replaced;
|
||||
|
||||
+ a relative path string - the pathname of the directory or file
|
||||
to be unpacked, relative to the plt directory; and
|
||||
|
||||
+ a path string for the plt directory.
|
||||
|
||||
If the filter procedure returns #f for a directory or file, the
|
||||
directory or file is not unpacked. If the filter procedure returns
|
||||
#t and the directory or file for 'dir or 'file already exists, it
|
||||
is not created. (The file for 'file-replace need not exist
|
||||
already.)
|
||||
|
||||
When a directory is unpacked, intermediate directies are created
|
||||
as necessary to create the specified directory. When a file is
|
||||
unpacked, the directory must already exist.
|
||||
|
||||
The unit is extracted from the archive using MzScheme's `read'
|
||||
and `eval' procedures.
|
||||
|
||||
Assuming that the unpacking unit calls the `unmztar' procedure, the
|
||||
archive should continue with unpackables. Unpackables are extracted
|
||||
until the end-of-file is found (as indicated by an `=' in the
|
||||
base64-encoded input archive).
|
||||
|
||||
An unpackable is one of the following:
|
||||
|
||||
* The symbol 'dir followed by a list. The `build-path' procedure
|
||||
will be applied to the list to obtain a relative path for the
|
||||
directory (and the relatie path is combined with the plt directory
|
||||
path to ge a complete path).
|
||||
|
||||
The 'dir symbol and list are extracted from the archive using
|
||||
MzScheme's `read' (and the result is *not* `eval'uated).
|
||||
|
||||
* The symbol 'file, a list, a number, an asterisk, and the file
|
||||
data. The list specifies the file's relative path, just as for
|
||||
directories. The number indicates the size of the file to be
|
||||
unpacked in bytes. The asterisk indicates the start of the file
|
||||
data; the next n bytes are written to the file, where n is the
|
||||
specified size of the file.
|
||||
|
||||
The symbol, list, and number are all extracted from the archive
|
||||
using MzScheme's `read' (and the result is *not* `eval'uated).
|
||||
After the number is read, input characters are discarded until
|
||||
an asterisk is found. The file data must follow this asterisk
|
||||
immediately.
|
||||
|
||||
* The symbol 'file-replace is treated like 'file, but if the file
|
||||
exists on disk already, the file in the archive replaces the file
|
||||
on disk.
|
||||
|
||||
Making .plt archives
|
||||
--------------------
|
||||
|
||||
The setup collection's pack.ss library provides functions to help
|
||||
make .plt archives, especially under Unix:
|
||||
|
||||
> (pack dest name paths collections [filter encode? file-mode]) -
|
||||
Creates the .plt file specified by the pathname `dest', using the
|
||||
string `name' as the name reported to Setup PLT as the archive's
|
||||
description, and `collections' as the list of colection paths
|
||||
returned by the unpacking unit. The `paths argument must be a list
|
||||
of relative paths for directories and files; the contents of these
|
||||
files and directories will be packed into the archive.
|
||||
|
||||
The `filter' procedure is called with the relative path of each
|
||||
candidate for packing. If it returns #f for some path, then that
|
||||
file or directory is omitted from the archive. If it returns 'file
|
||||
or 'file-replace for a file, the file is packed with that mode,
|
||||
rather than the default mode. The default `filter' is `std-filter'
|
||||
(defined below).
|
||||
|
||||
If `encode?' is #f, then the output archive is in raw form, and
|
||||
still must be gzipped and mime-encoded. If `encode?' is #t, then
|
||||
gzip and mmencode must be in the shell's path for executables.
|
||||
the default value is #t.
|
||||
|
||||
The `file-mode' argument must be 'file or 'file-replace, indicating
|
||||
the default mode for a file in the archive. The default value is
|
||||
'file.
|
||||
|
||||
> (std-filter p) - returns #t unless `p' matches one of the following
|
||||
regular expressions: "CVS$", "compiled$", "~$", or "^#.*#$".
|
||||
|
||||
> (mztar path output filter file-mode) - called by `pack' to write one
|
||||
directory/file `path' to the output port `output' using the filter
|
||||
procedure `filter' (see `pack' for a description of `filter'). The
|
||||
`file-mode' argument specifies the default mode for packing a file,
|
||||
either 'file or 'file-replace.
|
||||
|
||||
Setup PLT as a Unit
|
||||
-------------------
|
||||
|
||||
The _setupr.ss_ library in the setup collection contains a signed
|
||||
unit that imports
|
||||
|
||||
setup-option^ - described below
|
||||
mzlib:file^
|
||||
compiler^ - from sig.ss in the compiler collection
|
||||
compiler:option^ - from sig.ss in the compiler collection
|
||||
launcher-maker^ - from launchers.ss in the `launcher' collection
|
||||
|
||||
Invoking this unit starts the setup process. The _setupsig.ss_ library
|
||||
defines the
|
||||
> setup-option^
|
||||
signature, which is implemented by the unit in _setup-optionr.ss_. It
|
||||
defines the following parameters that control the setup process:
|
||||
|
||||
> verbose - #t => prints message from `make' to stderr [default: #f]
|
||||
> make-verbose - #t => verbose `make' [default: #f]
|
||||
> compiler-verbose - #t => verbose `compiler' [default: #f]
|
||||
> clean - #t => delete .zo and .so/.dll files in the specified collections
|
||||
[default: #f]
|
||||
> make-zo - #t => compile .zo files [default #t]
|
||||
> make-so - #t => compile .so/.dll files [default: #f]
|
||||
> make-launchers - #t => make collection info.ss-specified launchers
|
||||
[default: #t]
|
||||
> call-install - #t => call collection info.ss-specified setup code
|
||||
[default: #t]
|
||||
> specific-collections - a list of collections to set up; the empty
|
||||
list means set-up all collections if the archives
|
||||
list is also empty [default: null]
|
||||
> archives - a list of .plt archives to unpack; any collections specified
|
||||
by the archives are set-up in addition to the collections
|
||||
listed in specific-collections [default: null]
|
||||
|
||||
Thus, to unpack a single .plt archive "x.plt", set the `archives'
|
||||
parameter to (list "x.plt") and leave `specific-collections' as null.
|
||||
|
||||
Link the options and setup units so that your option-setting code is
|
||||
initialized between them, e.g.:
|
||||
|
||||
(compound-unit/sig
|
||||
...
|
||||
(link ...
|
||||
[OPTIONS : setup-option^
|
||||
((require-library "setup-optionr.ss" "setup"))]
|
||||
[MY-CODE : ()
|
||||
((require-library "init-options.ss") OPTIONS)]
|
||||
[SETUP : ()
|
||||
((require-library "setupr.ss" "setup")
|
||||
OPTIONS ...)])
|
||||
...)
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
|
||||
(lambda (request failure)
|
||||
(case request
|
||||
[(name) "Setup PLT"]
|
||||
[(compile-prefix) `(begin
|
||||
(require-library "refer.ss")
|
||||
(require-library "setupsig.ss" "setup"))]
|
||||
[(compile-omit-files) (list "setup.ss" "setupsig.ss")]
|
||||
[(compile-elaboration-zos) (list "setupsig.ss")]
|
||||
[(mzscheme-launcher-libraries) (list "setup.ss")]
|
||||
[(mzscheme-launcher-names) (list "Setup PLT")]
|
||||
[else (failure)]))
|
||||
|
|
@ -1,100 +0,0 @@
|
|||
|
||||
;; Utilities for creating a .plt package, relies on gzip and mmencode
|
||||
|
||||
(define pack
|
||||
(case-lambda
|
||||
[(dest name paths collections)
|
||||
(pack dest name paths collections std-filter #t 'file)]
|
||||
[(dest name paths collections filter)
|
||||
(pack dest name paths collections filter #t 'file)]
|
||||
[(dest name paths collections filter encode?)
|
||||
(pack dest name paths collections filter encode? 'file)]
|
||||
[(dest name paths collections filter encode? file-mode)
|
||||
(let* ([p (if encode?
|
||||
(process (format "gzip -c | mmencode > ~s" dest))
|
||||
#f)]
|
||||
[stdin (if p
|
||||
(cadr p)
|
||||
(open-output-file dest 'truncate/replace))]
|
||||
[echo (lambda (p)
|
||||
(thread
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(let ([l (read-line p 'any)])
|
||||
(unless (eof-object? l)
|
||||
(printf "~a~n" l)
|
||||
(loop)))))))]
|
||||
[t1 (and p (echo (car p)))]
|
||||
[t2 (and p (echo (list-ref p 3)))])
|
||||
(fprintf stdin "PLT~n")
|
||||
(write
|
||||
`(lambda (request failure)
|
||||
(case request
|
||||
[(name) ,name]
|
||||
[(unpacker) 'mzscheme]))
|
||||
stdin)
|
||||
(newline stdin)
|
||||
(write
|
||||
`(unit
|
||||
(import plthome mzuntar)
|
||||
(export)
|
||||
(mzuntar void)
|
||||
(quote ,collections))
|
||||
stdin)
|
||||
(newline stdin)
|
||||
(for-each
|
||||
(lambda (path)
|
||||
(mztar path stdin filter file-mode))
|
||||
paths)
|
||||
(close-output-port stdin)
|
||||
(when p
|
||||
(thread-wait t1)
|
||||
(thread-wait t2)))]))
|
||||
|
||||
(define (mztar path output filter file-mode)
|
||||
(define (path->list p)
|
||||
(let-values ([(base name dir?) (split-path p)])
|
||||
(if (string? base)
|
||||
(append (path->list base) (list name))
|
||||
(list name))))
|
||||
(define-values (init-dir init-files)
|
||||
(if (file-exists? path)
|
||||
(let-values ([(base name dir?) (split-path path)])
|
||||
(values base (list name)))
|
||||
(values path #f)))
|
||||
|
||||
(let loop ([dir init-dir][dpath (path->list init-dir)][files init-files])
|
||||
(printf "MzTarring ~a~a...~n" dir
|
||||
(if files (car files) ""))
|
||||
(fprintf output "~s~n~s~n" 'dir dpath)
|
||||
(for-each
|
||||
(lambda (f)
|
||||
(let* ([p (build-path dir f)]
|
||||
[filter-val (filter p)])
|
||||
(when filter-val
|
||||
(if (directory-exists? p)
|
||||
(loop p (append dpath (list f)) #f)
|
||||
(let ([len (file-size p)])
|
||||
; (printf "MzTarring ~a~n" p)
|
||||
(fprintf output "~s~n~s~n~s~n*"
|
||||
(case filter-val
|
||||
[(file) 'file]
|
||||
[(file-replace) 'file-replace]
|
||||
[else file-mode])
|
||||
(append dpath (list f))
|
||||
len)
|
||||
(with-input-from-file p
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(let ([c (read-char)])
|
||||
(unless (eof-object? c)
|
||||
(write-char c output)
|
||||
(loop)))))))))))
|
||||
(or files (directory-list dir)))))
|
||||
|
||||
(define (std-filter path)
|
||||
(not (or (regexp-match "CVS$" path)
|
||||
(regexp-match "compiled$" path)
|
||||
(regexp-match "~$" path)
|
||||
(regexp-match "^#.*#$" path))))
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user