suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

merged units branch

Browse Source 
svn: r5033

original commit: 3459c3a58f1cdc52fbc916acf306b29408468912
This commit is contained in:
Eli Barzilay 2006-12-05 20:31:14 +00:00
parent 187a45b1ab
commit 5401208e73
43 changed files with 3494 additions and 1941 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/mzlib/a-signature.ss Normal file
View File

@ -0,0 +1,29 @@
(module a-signature mzscheme
(require-for-syntax "private/unit-compiletime.ss"
"private/unit-syntax.ss")
(require "unit.ss")
(provide (rename module-begin #%module-begin)
(all-from-except mzscheme #%module-begin)
(all-from "unit.ss"))
(define-for-syntax (make-name s)
(string->symbol
(string-append (regexp-replace "-sig$" (symbol->string s) "")
"^")))
(define-syntax (module-begin stx)
(parameterize ((error-syntax stx))
(with-syntax ((name (make-name (syntax-property stx 'enclosing-module-name))))
(syntax-case stx ()
((_ . x)
(with-syntax ((((reqs ...) . (body ...))
(split-requires (checked-syntax->list #'x))))
(datum->syntax-object
stx
(syntax-e #'(#%module-begin
reqs ...
(provide name)
(define-signature name (body ...))))
stx))))))))

28
collects/mzlib/a-unit.ss Normal file
View File

@ -0,0 +1,28 @@
(module a-unit mzscheme
(require-for-syntax "private/unit-compiletime.ss"
"private/unit-syntax.ss")
(require "unit.ss")
(provide (rename module-begin #%module-begin)
(all-from-except mzscheme #%module-begin)
(all-from "unit.ss"))
(define-for-syntax (make-name s)
(string->symbol
(string-append (regexp-replace "-unit$" (symbol->string s) "")
"@")))
(define-syntax (module-begin stx)
(parameterize ((error-syntax stx))
(with-syntax ((name (make-name (syntax-property stx 'enclosing-module-name))))
(syntax-case stx ()
((_ . x)
(with-syntax ((((reqs ...) . (body ...))
(split-requires (checked-syntax->list #'x))))
(datum->syntax-object
stx
(syntax-e #'(#%module-begin
reqs ...
(provide name)
(define-unit name body ...)))
stx))))))))

2
collects/mzlib/deflate.ss
View File

@ -12,7 +12,7 @@
(provide deflate gzip-through-ports gzip) (provide deflate gzip-through-ports gzip)
(require "unit.ss") (require "unit200.ss")
(define-syntax INSERT_STRING (define-syntax INSERT_STRING
(syntax-rules () (syntax-rules ()

2
collects/mzlib/private/sigmatch.ss
View File

@ -1,7 +1,7 @@
(module sigmatch mzscheme (module sigmatch mzscheme
(require "../unit.ss") (require "../unit200.ss")
(define (hash-sig src-sig table) (define (hash-sig src-sig table)
(and (pair? src-sig) (and (pair? src-sig)

2
collects/mzlib/private/sigutil.ss
View File

@ -8,7 +8,7 @@
(lib "context.ss" "syntax")) (lib "context.ss" "syntax"))
(require "sigmatch.ss") (require "sigmatch.ss")
(require "../unit.ss") (require "../unit200.ss")
(require "../list.ss") (require "../list.ss")
(define-struct signature (name ; sym (define-struct signature (name ; sym

26
collects/mzlib/unit-exptime.ss Normal file
View File

@ -0,0 +1,26 @@
(module unit-exptime mzscheme
(require "private/unit-syntax.ss"
"private/unit-compiletime.ss")
(provide unit-static-signatures
signature-members)
(define (unit-static-signatures name err-stx)
(parameterize ((error-syntax err-stx))
(let ((ui (lookup-def-unit name)))
(values (apply list-immutable (unit-info-import-sig-ids ui))
(apply list-immutable (unit-info-export-sig-ids ui))))))
(define (signature-members name err-stx)
(parameterize ((error-syntax err-stx))
(let ([s (lookup-signature name)])
(values
;; extends:
(and (pair? (cdr (siginfo-names (signature-siginfo s))))
(cadr (siginfo-names (signature-siginfo s))))
;; vars
(apply list-immutable (signature-vars s))
;; defined vars
(apply list-immutable (apply append (map car (signature-val-defs s))))
;; defined stxs
(apply list-immutable (apply append (map car (signature-stx-defs s)))))))))

2475
collects/mzlib/unit.ss
View File

File diff suppressed because it is too large Load Diff

869
collects/mzlib/unit200.ss Normal file
View File

@ -0,0 +1,869 @@
;; Unit system
(module unit200 mzscheme
(require-for-syntax (lib "kerncase.ss" "syntax")
(lib "stx.ss" "syntax")
(lib "name.ss" "syntax")
(lib "context.ss" "syntax")
"list.ss"
"private/unitidmap.ss")
;; ----------------------------------------------------------------------
;; Structures and helpers
(define undefined (letrec ([x x]) x)) ; initial value
(define insp (current-inspector)) ; for named structures
(define-struct unit (num-imports exports go)) ; unit value
(define-struct (exn:fail:unit exn:fail) ()) ; run-time exception
;; For units with inferred names, generate a struct that prints using the name:
(define (make-naming-constructor type name)
(let-values ([(struct: make- ? -accessor -mutator)
(make-struct-type name type 0 0 #f null insp)])
make-))
;; Make a unt value (call by the macro expansion of `unit')
(define (make-a-unit name num-imports exports go)
((if name
(make-naming-constructor
struct:unit
(string->symbol (format "unit:~a" name)))
make-unit)
num-imports exports go))
;; ----------------------------------------------------------------------
;; The `unit' syntactic form
(define-syntaxes (:unit unit/no-expand)
(let ([do-unit
(lambda (stx expand?)
(syntax-case stx (import export)
[(_ (import ivar ...)
(export evar ...)
defn&expr ...)
(let ([check-id (lambda (v)
(unless (identifier? v)
(raise-syntax-error
#f
"import is not an identifier"
stx
v)))]
[check-renamed-id
(lambda (v)
(syntax-case v ()
[id (identifier? (syntax id)) (list v)]
[(lid eid) (and (identifier? (syntax lid))
(identifier? (syntax eid)))
(list #'lid #'eid)]
[else (raise-syntax-error
#f
"export is not an identifier or renamed identifier"
stx
v)]))]
[expand-context (generate-expand-context)]
[def-ctx (and expand?
(syntax-local-make-definition-context))]
[localify (lambda (ids def-ctx)
(if (andmap identifier? ids)
;; In expand mode, add internal defn context
(if expand?
(begin
;; Treat imports as internal-defn names:
(syntax-local-bind-syntaxes ids #f def-ctx)
(cdr (syntax->list
(local-expand #`(stop #,@ids)
'expression
(list #'stop)
def-ctx))))
ids)
;; Let later checking report an error:
ids))])
(let ([ivars (localify (syntax->list (syntax (ivar ...))) def-ctx)]
[evars (syntax->list (syntax (evar ...)))])
(for-each check-id ivars)
(for-each check-renamed-id evars)
;; Get import/export declared names:
(let* ([exported-names
(localify
(map (lambda (v)
(syntax-case v ()
[(lid eid) (syntax lid)]
[id (syntax id)]))
evars)
def-ctx)]
[extnames (map (lambda (v)
(syntax-case v ()
[(lid eid) (syntax eid)]
[id (syntax id)]))
evars)]
[imported-names ivars]
[declared-names (append imported-names exported-names)])
;; Check that all exports are distinct (as symbols)
(let ([ht (make-hash-table)])
(for-each (lambda (name)
(when (hash-table-get ht (syntax-e name) (lambda () #f))
(raise-syntax-error
#f
"duplicate export"
stx
name))
(hash-table-put! ht (syntax-e name) #t))
extnames))
;; Expand all body expressions
;; so that all definitions are exposed.
(letrec ([expand-all
(if expand?
(lambda (defns&exprs)
(apply
append
(map
(lambda (defn-or-expr)
(let ([defn-or-expr
(local-expand
defn-or-expr
expand-context
(append
(kernel-form-identifier-list (quote-syntax here))
declared-names)
def-ctx)])
(syntax-case defn-or-expr (begin define-values define-syntaxes)
[(begin . l)
(let ([l (syntax->list (syntax l))])
(unless l
(raise-syntax-error
#f
"bad syntax (illegal use of `.')"
defn-or-expr))
(expand-all (map (lambda (s)
(syntax-track-origin s defn-or-expr #'begin))
l)))]
[(define-syntaxes (id ...) rhs)
(andmap identifier? (syntax->list #'(id ...)))
(with-syntax ([rhs (local-transformer-expand
#'rhs
'expression
null)])
(syntax-local-bind-syntaxes (syntax->list #'(id ...)) #'rhs def-ctx)
(list #'(define-syntaxes (id ...) rhs)))]
[(define-values (id ...) rhs)
(andmap identifier? (syntax->list #'(id ...)))
(begin
(syntax-local-bind-syntaxes (syntax->list #'(id ...)) #f def-ctx)
(list defn-or-expr))]
[else (list defn-or-expr)])))
defns&exprs)))
values)])
(let ([all-expanded (expand-all (syntax->list (syntax (defn&expr ...))))])
;; Get all the defined names, sorting out variable definitions
;; from syntax definitions.
(let* ([definition?
(lambda (id)
(and (identifier? id)
(or (module-identifier=? id (quote-syntax define-values))
(module-identifier=? id (quote-syntax define-syntaxes)))))]
[all-defined-names/kinds
(apply
append
(map
(lambda (defn-or-expr)
(syntax-case defn-or-expr (define-values define-syntaxes)
[(dv (id ...) expr)
(definition? (syntax dv))
(let ([l (syntax->list (syntax (id ...)))])
(for-each (lambda (i)
(unless (identifier? i)
(raise-syntax-error
#f
"not an identifier in definition"
defn-or-expr
i)))
l)
(let ([key (if (module-identifier=? (syntax dv) (quote-syntax define-syntaxes))
'stx
'val)])
(map (lambda (id) (cons key id)) l)))]
[(define-values . l)
(raise-syntax-error
#f
"bad definition form"
defn-or-expr)]
[(define-syntaxes . l)
(raise-syntax-error
#f
"bad syntax definition form"
defn-or-expr)]
[else null]))
all-expanded))]
[all-defined-names (map cdr all-defined-names/kinds)]
[all-defined-val-names (map cdr
(filter (lambda (i) (eq? (car i) 'val))
all-defined-names/kinds))])
;; Check that all defined names (var + stx) are distinct:
(let ([name (check-duplicate-identifier
(append imported-names all-defined-names))])
(when name
(raise-syntax-error
#f
"variable imported and/or defined twice"
stx
name)))
;; Check that all exported names are defined (as var):
(let ([ht (make-hash-table)]
[stx-ht (make-hash-table)])
(for-each
(lambda (kind+name)
(let ([name (cdr kind+name)])
(let ([l (hash-table-get ht (syntax-e name) (lambda () null))])
(hash-table-put! (if (eq? (car kind+name) 'val) ht stx-ht)
(syntax-e name)
(cons name l)))))
all-defined-names/kinds)
(for-each
(lambda (n)
(let ([v (hash-table-get ht (syntax-e n) (lambda () null))])
(unless (ormap (lambda (i) (bound-identifier=? i n)) v)
;; Either not defined, or defined as syntax:
(let ([stx-v (hash-table-get stx-ht (syntax-e n) (lambda () null))])
(if (ormap (lambda (i) (bound-identifier=? i n)) stx-v)
(raise-syntax-error
#f
"cannot export syntax from a unit"
stx
n)
(raise-syntax-error
#f
"exported variable is not defined"
stx
n))))))
exported-names))
;; Compute defined but not exported:
(let ([ht (make-hash-table)])
(for-each
(lambda (name)
(let ([l (hash-table-get ht (syntax-e name) (lambda () null))])
(hash-table-put! ht (syntax-e name) (cons name l))))
exported-names)
(let ([internal-names
(let loop ([l all-defined-val-names])
(cond
[(null? l) null]
[(let ([v (hash-table-get ht (syntax-e (car l)) (lambda () null))])
(ormap (lambda (i) (bound-identifier=? i (car l))) v))
(loop (cdr l))]
[else (cons (car l) (loop (cdr l)))]))])
;; Generate names for import/export boxes, etc:
(with-syntax ([(ivar ...) ivars]
[(iloc ...) (generate-temporaries ivars)]
[(eloc ...) (generate-temporaries evars)]
[(extname ...) extnames]
[(expname ...) exported-names]
[(intname ...) internal-names])
;; Change all definitions to set!s. Convert evars to set-box!,
;; because set! on exported variables is not allowed.
(with-syntax ([(defn&expr ...)
(let ([elocs (syntax->list (syntax (eloc ...)))])
(filter
values
(map (lambda (defn-or-expr)
(syntax-case defn-or-expr (define-values define-syntaxes)
[(define-values ids expr)
(let* ([ids (syntax->list (syntax ids))])
(if (null? ids)
(syntax/loc defn-or-expr (set!-values ids expr))
(let ([do-one
(lambda (id tmp name)
(let loop ([evars exported-names]
[elocs elocs])
(cond
[(null? evars)
;; not an exported id
(with-syntax ([id id][tmp tmp])
(syntax/loc
defn-or-expr
(set! id tmp)))]
[(bound-identifier=? (car evars) id)
;; set! exported id:
(with-syntax
([loc (car elocs)]
[tmp
(if name
(with-syntax
([tmp tmp]
[name name])
(syntax
(let ([name tmp])
name)))
tmp)])
(syntax/loc defn-or-expr
(set-box! loc tmp)))]
[else (loop (cdr evars)
(cdr elocs))])))])
(if (null? (cdr ids))
(do-one (car ids) (syntax expr) (car ids))
(let ([tmps (generate-temporaries ids)])
(with-syntax ([(tmp ...) tmps]
[(set ...)
(map (lambda (id tmp)
(do-one id tmp #f))
ids tmps)])
(syntax/loc defn-or-expr
(let-values ([(tmp ...) expr])
set ...))))))))]
[(define-syntaxes . l) #f]
[else defn-or-expr]))
all-expanded)))]
[(stx-defn ...)
(filter
values
(map (lambda (defn-or-expr)
(syntax-case defn-or-expr (define-syntaxes)
[(define-syntaxes . l) #'l]
[else #f]))
all-expanded))])
;; Build up set! redirection chain:
(with-syntax ([redirections
(let ([varlocs
(syntax->list
(syntax ((ivar iloc) ... (expname eloc) ...)))])
(with-syntax ([vars (map stx-car varlocs)]
[rhss
(map
(lambda (varloc)
(with-syntax ([(var loc) varloc])
(syntax
(make-id-mapper (quote-syntax (unbox loc))
(quote-syntax var)))))
varlocs)])
(syntax
([vars (values . rhss)]))))]
[num-imports (datum->syntax-object
(quote-syntax here)
(length (syntax->list (syntax (iloc ...))))
#f)]
[name (syntax-local-infer-name stx)])
(syntax/loc stx
(make-a-unit
'name
num-imports
(list (quote extname) ...)
(lambda ()
(let ([eloc (box undefined)] ...)
(list (vector eloc ...)
(lambda (iloc ...)
(letrec-syntaxes+values
(stx-defn ... . redirections)
([(intname) undefined] ...)
(void) ; in case the body would be empty
defn&expr ...))))))))))))))))))]))])
(values (lambda (stx) (do-unit stx #t))
(lambda (stx) (do-unit stx #f)))))
;; ----------------------------------------------------------------------
;; check-expected-interface: used by the expansion of `compound-unit'
(define (check-expected-interface tag unit num-imports exports)
(unless (unit? unit)
(raise
(make-exn:fail:unit
(string->immutable-string
(format "compound-unit: result of expression for tag ~s not a unit: ~e" tag unit))
(current-continuation-marks))))
(unless (= num-imports (unit-num-imports unit))
(raise
(make-exn:fail:unit
(string->immutable-string
(format "compound-unit: unit for tag ~s expects ~a imports, given ~a"
tag
(unit-num-imports unit)
num-imports))
(current-continuation-marks))))
(list->vector
(map (lambda (ex)
(let loop ([l (unit-exports unit)][i 0])
(cond
[(null? l)
(raise
(make-exn:fail:unit
(string->immutable-string
(format "compound-unit: unit for tag ~s has no ~s export"
tag ex))
(current-continuation-marks)))]
[(eq? (car l) ex)
i]
[else (loop (cdr l) (add1 i))])))
exports)))
;; ----------------------------------------------------------------------
;; The `compound-unit' syntactic form
(define-syntax compound-unit
(lambda (stx)
(syntax-case stx (import export link)
[(_ (import ivar ...)
(link [tag (unit-expr linkage ...)] ...)
(export exportage ...))
(let ([check-id (lambda (v)
(unless (identifier? v)
(raise-syntax-error
#f
"import is not an identifier"
stx
v)))]
[check-tag (lambda (v)
(unless (identifier? v)
(raise-syntax-error
#f
"tag is not an identifier"
stx
v)))]
[check-linkage (lambda (v)
(syntax-case v ()
[id (identifier? (syntax id)) #t]
[(tag id ...)
(for-each (lambda (v)
(unless (identifier? v)
(raise-syntax-error
#f
"non-identifier in linkage"
stx
v)))
(syntax->list v))]
[else
(raise-syntax-error
#f
"ill-formed linkage"
stx
v)]))]
[check-exportage (lambda (v)
(syntax-case v ()
[(tag ex ...)
(begin
(unless (identifier? (syntax tag))
(raise-syntax-error
#f
"export tag is not an identifier"
stx
(syntax tag)))
(for-each
(lambda (e)
(syntax-case e ()
[id (identifier? (syntax id)) #t]
[(iid eid)
(begin
(unless (identifier? (syntax iid))
(raise-syntax-error
#f
"export internal name is not an identifier"
stx
(syntax iid)))
(unless (identifier? (syntax eid))
(raise-syntax-error
#f
"export internal name is not an identifier"
stx
(syntax eid))))]
[else
(raise-syntax-error
#f
(format "ill-formed export with tag ~a"
(syntax-e (syntax tag)))
stx
e)]))
(syntax->list (syntax (ex ...)))))]
[else
(raise-syntax-error
#f
"ill-formed export"
stx
v)]))]
[imports (syntax->list (syntax (ivar ...)))]
[tags (syntax->list (syntax (tag ...)))]
[linkages (map syntax->list (syntax->list (syntax ((linkage ...) ...))))]
[exports (syntax->list (syntax (exportage ...)))])
;; Syntax checks:
(for-each check-id imports)
(for-each check-tag tags)
(for-each (lambda (l) (for-each check-linkage l)) linkages)
(for-each check-exportage exports)
;; Check for duplicate imports
(let ([dup (check-duplicate-identifier imports)])
(when dup
(raise-syntax-error
#f
"duplicate import"
stx
dup)))
;; Check for duplicate tags
(let ([dup (check-duplicate-identifier tags)])
(when dup
(raise-syntax-error
#f
"duplicate tag"
stx
dup)))
;; Check referenced imports and tags
(let ([check-linkage-refs (lambda (v)
(syntax-case v ()
[(tag . exs)
(unless (ormap (lambda (t)
(bound-identifier=? t (syntax tag)))
tags)
(raise-syntax-error
#f
"linkage tag is not bound"
stx
(syntax tag)))]
[id (unless (ormap (lambda (i)
(bound-identifier=? i (syntax id)))
imports)
(raise-syntax-error
#f
"no imported identified for linkage"
stx
(syntax id)))]))]
[check-export-refs (lambda (v)
(syntax-case v ()
[(tag . r)
(unless (ormap (lambda (t)
(bound-identifier=? t (syntax tag)))
tags)
(raise-syntax-error
#f
"export tag is not bound"
stx
(syntax tag)))]))])
(for-each (lambda (l) (for-each check-linkage-refs l))
linkages)
(for-each check-export-refs exports)
;; Get all export names, and check for duplicates
(let ([export-names
(apply
append
(map
(lambda (v)
(syntax-case v ()
[(tag . exs)
(map
(lambda (e)
(syntax-case e ()
[(iid eid) (syntax eid)]
[id e]))
(syntax->list (syntax exs)))]))
exports))])
(let ([dup (check-duplicate-identifier export-names)])
(when dup
(raise-syntax-error
#f
"duplicate export"
stx
dup)))
(let ([constituents (generate-temporaries tags)]
[unit-export-positionss (generate-temporaries tags)]
[unit-setups (generate-temporaries tags)]
[unit-extracts (generate-temporaries tags)]
[unit-export-lists
;; For each tag, get all expected exports
(let* ([hts (map (lambda (x) (make-hash-table)) tags)]
[get-add-name
(lambda (tag)
(ormap (lambda (t ht)
(and (bound-identifier=? t tag)
(lambda (name)
(hash-table-put! ht (syntax-e name) name))))
tags hts))])
;; Walk though linkages
(for-each
(lambda (linkage-list)
(for-each
(lambda (linkage)
(syntax-case linkage ()
[(tag . ids)
(let ([add-name (get-add-name (syntax tag))])
(for-each add-name (syntax->list (syntax ids))))]
[else (void)]))
linkage-list))
linkages)
;; Walk through exports
(for-each
(lambda (v)
(syntax-case v ()
[(tag . exs)
(let ([add-name (get-add-name (syntax tag))])
(for-each
(lambda (e)
(syntax-case e ()
[(iid eid) (add-name (syntax iid))]
[id (add-name (syntax id))]))
(syntax->list (syntax exs))))]))
exports)
;; Extract names from hash tables
(map (lambda (ht)
(hash-table-map ht (lambda (k v) v)))
hts))])
;; Map exports to imports and indices based on expected unit exports
(let ([map-tag (lambda (t l)
(let loop ([tags tags][l l])
(if (bound-identifier=? (car tags) t)
(car l)
(loop (cdr tags) (cdr l)))))]
[unit-export-hts (map (lambda (export-list)
(let ([ht (make-hash-table)])
(let loop ([l export-list][p 0])
(unless (null? l)
(hash-table-put! ht (syntax-e (car l)) p)
(loop (cdr l) (add1 p))))
ht))
unit-export-lists)]
[interned-integer-lists null]
[interned-id-lists null])
(let ([make-mapping
(lambda (v)
(syntax-case v ()
[(tag . exs)
(let ([extract (map-tag (syntax tag)
unit-extracts)]
[ht (map-tag (syntax tag)
unit-export-hts)])
(with-syntax ([extract extract]
[pos-name
(let ([il
(map
(lambda (e)
(hash-table-get
ht
(syntax-e
(syntax-case e ()
[(iid eid) (syntax iid)]
[id e]))))
(syntax->list (syntax exs)))])
(or (ormap (lambda (i)
(and (equal? il (cadadr i))
(car i)))
interned-integer-lists)
(let ([name (car (generate-temporaries
(list (syntax tag))))])
(set! interned-integer-lists
(cons `(,name ',il)
interned-integer-lists))
name)))])
(syntax (map extract pos-name))))]
[import v]))]
[collapse (lambda (l)
(let loop ([l l])
(cond
[(null? l) null]
[(identifier? (car l))
(let-values ([(ids rest)
(let loop ([l l][ids null])
(if (or (null? l)
(not (identifier? (car l))))
(values (reverse ids) l)
(loop (cdr l) (cons (car l) ids))))])
(let ([name
(let ([id-syms (map syntax-e ids)])
(or (ormap (lambda (i)
(and (equal? id-syms (cadr i))
(car i)))
interned-id-lists)
(let ([name
(car (generate-temporaries (list 'ids)))])
(set! interned-id-lists
(cons (list* name id-syms ids)
interned-id-lists))
name)))])
(cons name
(loop rest))))]
[else (cons (car l) (loop (cdr l)))])))])
(let ([export-mapping (collapse (map make-mapping exports))]
[import-mappings (map (lambda (linkage-list)
(collapse
(map make-mapping linkage-list)))
linkages)])
(with-syntax ([(constituent ...) constituents]
[(unit-export-positions ...) unit-export-positionss]
[(unit-setup ...) unit-setups]
[(unit-extract ...) unit-extracts]
[interned-integer-lists interned-integer-lists]
[interned-id-lists (map (lambda (i)
(with-syntax ([name (car i)]
[ids (cddr i)])
(syntax [name (list . ids)])))
interned-id-lists)]
[(unit-export-list ...) unit-export-lists]
[(import-mapping ...) import-mappings]
[(unit-import-count ...)
(map (lambda (l)
(datum->syntax-object
(quote-syntax here)
(apply
+
(map (lambda (v)
(if (identifier? v)
1
(length (cdr (syntax->list v)))))
l))
#f))
linkages)]
[num-imports (datum->syntax-object
(quote-syntax here)
(length imports)
#f)]
[export-names export-names]
[export-mapping export-mapping]
[name (syntax-local-infer-name stx)])
(syntax/loc
stx
(let ([constituent unit-expr]
...)
(let ([unit-export-positions
(check-expected-interface
'tag
constituent
unit-import-count
'unit-export-list)]
...)
(make-a-unit
'name
num-imports
(quote export-names)
(lambda ()
(let ([unit-setup ((unit-go constituent))] ...)
(let ([unit-extract
(lambda (pos)
(vector-ref (car unit-setup)
(vector-ref unit-export-positions pos)))]
...
.
interned-integer-lists)
(list (list->vector (append . export-mapping))
(lambda (ivar ...)
(let interned-id-lists
(void) ;; in case there are no units
(apply (list-ref unit-setup 1)
(append . import-mapping))
...))))))))))))))))))])))
;; ----------------------------------------------------------------------
;; check-unit: used by the expansion of `invoke-unit'
(define (check-unit u n)
(unless (unit? u)
(raise
(make-exn:fail:unit
(string->immutable-string
(format "invoke-unit: result of unit expression was not a unit: ~e" u))
(current-continuation-marks))))
(unless (= (unit-num-imports u) n)
(raise
(make-exn:fail:unit
(string->immutable-string
(format "invoke-unit: expected a unit with ~a imports, given one with ~a imports"
n (unit-num-imports u)))
(current-continuation-marks)))))
;; ----------------------------------------------------------------------
;; The `invoke-unit' syntactic form
(define-syntax invoke-unit
(lambda (stx)
(syntax-case stx (import export)
[(_ unit-expr expr ...)
(let ([exprs (syntax (expr ...))])
(with-syntax ([(bx ...) (generate-temporaries (syntax (expr ...)))]
[num (datum->syntax-object
(quote-syntax here)
(length (syntax->list exprs))
#f)])
(syntax/loc
stx
(let ([u unit-expr])
(check-unit u num)
(let ([bx (box expr)] ...)
((list-ref ((unit-go u)) 1)
bx ...))))))])))
(define-syntaxes (define-values/invoke-unit
namespace-variable-bind/invoke-unit)
(let ([mk
(lambda (global?)
(lambda (stx)
(syntax-case stx ()
[(_ exports unite . prefix+imports)
(let* ([badsyntax (lambda (s why)
(raise-syntax-error
#f
(format "bad syntax (~a)" why)
stx
s))]
[symcheck (lambda (s)
(or (identifier? s)
(badsyntax s "not an identifier")))])
(unless (stx-list? (syntax exports))
(badsyntax (syntax exports) "not a sequence of identifiers"))
(for-each symcheck (syntax->list (syntax exports)))
(let ([prefix (if (stx-null? (syntax prefix+imports))
#f
(stx-car (syntax prefix+imports)))])
(unless (or (not prefix)
(not (syntax-e prefix))
(identifier? prefix))
(badsyntax prefix "prefix is not an identifier"))
(for-each symcheck (let ([v (syntax prefix+imports)])
(cond
[(stx-null? v) null]
[(stx-list? v) (cdr (syntax->list v))]
[else
(badsyntax (syntax prefix+imports) "illegal use of `.'")])))
(with-syntax ([(tagged-export ...)
(if (and prefix (syntax-e prefix))
(let ([prefix (string-append
(symbol->string
(syntax-e prefix))
":")])
(map (lambda (s)
(datum->syntax-object
s
(string->symbol
(string-append
prefix
(symbol->string (syntax-e s))))
s))
(syntax->list (syntax exports))))
(syntax exports))]
[extract-unit (syntax (:unit
(import . exports)
(export)
(values . exports)))])
(with-syntax ([invoke-unit (with-syntax ([(x . imports)
(if prefix
(syntax prefix+imports)
`(#f))])
(syntax (invoke-unit
(compound-unit
(import . imports)
(link [unit-to-invoke (unite . imports)]
[export-extractor
(extract-unit (unit-to-invoke . exports))])
(export))
. imports)))])
(if global?
(syntax (let-values ([(tagged-export ...) invoke-unit])
(namespace-set-variable-value! 'tagged-export tagged-export)
...
(void)))
(syntax (define-values (tagged-export ...) invoke-unit)))))))])))])
(values (mk #f) (mk #t))))
(provide (rename :unit unit) unit/no-expand
compound-unit invoke-unit unit?
(struct exn:fail:unit ())
define-values/invoke-unit
namespace-variable-bind/invoke-unit))

360
collects/mzlib/unitsig.ss
View File

@ -1,360 +1,4 @@
;; This implementation of `unit/sig' was ported from the old v100
;; implementation, and then hacked a bit to produce more compact
;; output, and finally mangled to handle the v200 `struct' (with
;; compile-time information). It's in dire need of an overhaul.
(module unitsig mzscheme (module unitsig mzscheme
(require "unit.ss") (require (lib "unitsig200.ss"))
(require "private/sigmatch.ss") (provide (all-from (lib "unitsig200.ss"))))
(require-for-syntax "private/sigutil.ss")
(require-for-syntax "private/sigmatch.ss")
(require-for-syntax (lib "kerncase.ss" "syntax"))
(define-struct signed-unit (unit imports exports))
(define-syntax define-signature
(lambda (expr)
(syntax-case expr ()
[(_ name sig)
(identifier? (syntax name))
(let ([sig (get-sig 'define-signature expr (syntax-e (syntax name))
(syntax sig) #f)])
(with-syntax ([content (explode-sig sig #f)])
(syntax (define-syntax name
(make-sig (quote content))))))])))
(define-syntax let-signature
(lambda (expr)
(syntax-case expr ()
[(_ name sig . body)
(identifier? (syntax name))
(let ([sig (get-sig 'let-signature expr (syntax-e (syntax name))
(syntax sig) #f)])
(with-syntax ([content (explode-sig sig #f)])
(syntax (letrec-syntax ([name (make-sig (quote content))])
. body))))])))
(define-syntax unit/sig
(lambda (expr)
(syntax-case expr ()
[(_ sig . rest)
(let ([sig (get-sig 'unit/sig expr #f (syntax sig) #f)])
(let ([a-unit (parse-unit expr (syntax rest) sig
(kernel-form-identifier-list (quote-syntax here))
(quote-syntax define-values)
(quote-syntax define-syntaxes)
(quote-syntax begin))])
(check-signature-unit-body sig a-unit (parsed-unit-renames a-unit) 'unit/sig expr)
(with-syntax ([imports (parsed-unit-import-vars a-unit)]
[exports (datum->syntax-object
expr
(let ([vars (make-hash-table)])
(for-each (lambda (var)
(hash-table-put! vars (syntax-e var) var))
(parsed-unit-vars a-unit))
(map
(lambda (name)
(list (let ([name (do-rename name (parsed-unit-renames a-unit))])
(hash-table-get vars name name))
name))
(signature-vars sig)))
expr)]
[body (append
(reverse! (parsed-unit-body a-unit))
((parsed-unit-stx-checks a-unit) expr))]
[import-sigs (explode-named-sigs (parsed-unit-imports a-unit) #f)]
[export-sig (explode-sig sig #f)])
(syntax/loc expr
(make-signed-unit
(unit/no-expand
(import . imports)
(export . exports)
. body)
(quote import-sigs)
(quote export-sig))))))])))
(define-syntax compound-unit/sig
(lambda (expr)
(syntax-case expr ()
[(_ . body)
(let-values ([(tags
exprs
exploded-link-imports
exploded-link-exports
flat-imports
link-imports
flat-exports
exploded-imports
exploded-exports
boxed-interned-symbol-vectors)
(parse-compound-unit expr (syntax body))]
[(t) (lambda (l) (datum->syntax-object expr l expr))])
(with-syntax ([(tag ...) (t tags)]
[(uexpr ...) (t exprs)]
[(tagx ...) (t (map (lambda (t) (string->symbol (format "u:~a" t))) tags))]
[exploded-link-imports (t exploded-link-imports)]
[exploded-link-exports (t exploded-link-exports)]
[flat-imports (t flat-imports)]
[(link-import ...) (t link-imports)]
[flat-exports (t flat-exports)]
[exploded-imports (t exploded-imports)]
[exploded-exports (t exploded-exports)]
[interned-vectors (t (map (lambda (x) `(,(car x) (quote ,(cadr x))))
(unbox boxed-interned-symbol-vectors)))])
(syntax/loc
expr
(let ([tagx uexpr] ... . interned-vectors)
(alt-verify-linkage-signature-match
'compound-unit/sig
'(tag ...)
(list tagx ...)
`exploded-link-imports
`exploded-link-exports)
;; All checks done. Make the unit:
(make-signed-unit
(compound-unit
(import . flat-imports)
(link [tag ((signed-unit-unit tagx)
. link-import)]
...)
(export . flat-exports))
`exploded-imports
`exploded-exports)))))])))
(define-syntax invoke-unit/sig
(lambda (expr)
(syntax-case expr ()
[(_ u sig ...)
(let ([sigs (parse-invoke-vars 'invoke-unit/sig (syntax (sig ...)) expr)])
(with-syntax ([exploded-sigs (datum->syntax-object
expr
(explode-named-sigs sigs #f)
expr)]
[flat-sigs (datum->syntax-object
expr
(flatten-signatures sigs #f)
expr)])
(syntax/loc
expr
(let ([unt u])
(alt-verify-linkage-signature-match
(quote invoke-unit/sig)
(quote (invoke))
(list unt)
(quote ((#() . #())))
(quote (exploded-sigs)))
(invoke-unit (signed-unit-unit unt)
. flat-sigs)))))])))
(define-syntax unit->unit/sig
(lambda (expr)
(syntax-case expr ()
[(_ e (im-sig ...) ex-sig)
(let ([im-sigs (map (lambda (sig)
(get-sig 'unit->unit/sig expr #f sig #f))
(syntax->list (syntax (im-sig ...))))]
[ex-sig (get-sig 'unit->unit/sig expr #f (syntax ex-sig) #f)])
(with-syntax ([exploded-imports (datum->syntax-object
expr
(explode-named-sigs im-sigs #f)
expr)]
[exploded-exports (datum->syntax-object
expr
(explode-sig ex-sig #f)
expr)])
(syntax
(make-signed-unit
e
(quote exploded-imports)
(quote exploded-exports)))))])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define -verify-linkage-signature-match
(let ([make-exn make-exn:fail:unit]
[p-suffix (lambda (pos) (case pos [(1) 'st][(2) 'nd][(3) 'rd][else 'th]))])
(lambda (who tags units esigs isigs wrapped? unwrap)
(for-each
(lambda (u tag)
(unless (signed-unit? u)
(raise
(make-exn
(string->immutable-string
(format
"~s: expression for \"~s\" is not a signed unit: ~e"
who tag u))
(current-continuation-marks)))))
units tags)
(for-each
(lambda (u tag esig)
(-verify-signature-match
who #f
(format "specified export signature for ~a" tag)
esig
(format "export signature for actual ~a sub-unit" tag)
(signed-unit-exports u)
wrapped? unwrap))
units tags esigs)
(for-each
(lambda (u tag isig)
(let ([n (length (signed-unit-imports u))]
[c (length isig)])
(unless (= c n)
(raise
(make-exn
(string->immutable-string
(format
"~s: ~a unit imports ~a units, but ~a units were provided"
who tag n c))
(current-continuation-marks))))))
units tags isigs)
(for-each
(lambda (u tag isig)
(let loop ([isig isig][expecteds (signed-unit-imports u)][pos 1])
(unless (null? isig)
(let ([expected (car expecteds)]
[provided (car isig)])
(-verify-signature-match
who #t
(format "~a unit's ~s~s import (which is ~a)" tag
pos (p-suffix pos)
(car expected))
(cdr expected)
(format "~a's ~s~s linkage (which is ~a)"
tag
pos (p-suffix pos)
(car provided))
(cdr provided)
wrapped? unwrap)
(loop (cdr isig) (cdr expecteds) (add1 pos))))))
units tags isigs))))
(define verify-linkage-signature-match
(lambda (who tags units esigs isigs)
(-verify-linkage-signature-match who tags units esigs isigs values values)))
(define alt-verify-linkage-signature-match
(lambda (who tags units esigs isigs)
(-verify-linkage-signature-match who tags units esigs isigs pair? car)))
(define-syntax signature->symbols
(lambda (stx)
(syntax-case stx ()
[(_ name)
(identifier? (syntax name))
(let ([sig (get-sig 'signature->symbols stx #f (syntax name) #f)])
(with-syntax ([e (let cleanup ([p (explode-sig sig #f)])
;; Strip struct info:
(list->vector
(map (lambda (i)
(if (symbol? i)
i
(cons (car i) (cleanup (cdr i)))))
(vector->list (car p)))))])
(syntax 'e)))])))
;; Internal:
(define-syntax do-define-values/invoke-unit/sig
(lambda (stx)
(syntax-case stx ()
[(_ global? signame unite prefix imports orig)
(let* ([formname (if (syntax-e (syntax global?))
'namespace-variable-bind/invoke-unit/sig
'define-values/invoke-unit/sig)]
[badsyntax (lambda (s why)
(raise-syntax-error
#f
(format "bad syntax (~a)" why)
(syntax orig)
s))])
(unless (or (not (syntax-e (syntax prefix)))
(identifier? (syntax prefix)))
(badsyntax (syntax prefix) "prefix is not an identifier"))
(let ([ex-sig (get-sig formname (syntax orig) #f (syntax signame) (syntax signame))])
(let ([ex-exploded (explode-sig ex-sig #f)]
[ex-flattened (flatten-signature #f ex-sig #'signame)])
(let ([im-sigs
(parse-invoke-vars formname (syntax imports) (syntax orig))])
(let ([im-explodeds (explode-named-sigs im-sigs #f)]
[im-flattened (flatten-signatures im-sigs #f)]
[d->s (lambda (x) (datum->syntax-object (syntax orig) x (syntax orig)))])
(with-syntax ([dv/iu (if (syntax-e (syntax global?))
(quote-syntax namespace-variable-bind/invoke-unit)
(quote-syntax define-values/invoke-unit))]
[ex-flattened ex-flattened]
[ex-exploded (d->s ex-exploded)]
[im-explodeds (d->s im-explodeds)]
[im-flattened (d->s im-flattened)]
[formname formname]
[stx-decls (if (syntax-e (syntax global?))
null
(make-struct-stx-decls ex-sig #f #f (syntax signame) #f))])
(syntax/loc stx
(begin
(dv/iu
ex-flattened
(let ([unit-var unite])
(alt-verify-linkage-signature-match
'formname
'(invoke)
(list unit-var)
'(ex-exploded)
'(im-explodeds))
(signed-unit-unit unit-var))
prefix
. im-flattened)
. stx-decls))))))))])))
(define-syntax define-values/invoke-unit/sig
(lambda (stx)
(with-syntax ([orig stx])
(syntax-case stx ()
[(_ signame unit prefix . imports)
(syntax (do-define-values/invoke-unit/sig #f signame unit prefix imports orig))]
[(_ signame unit)
(syntax (do-define-values/invoke-unit/sig #f signame unit #f () orig))]))))
(define-syntax namespace-variable-bind/invoke-unit/sig
(lambda (stx)
(with-syntax ([orig stx])
(syntax-case stx ()
[(_ signame unit prefix . imports)
(syntax (do-define-values/invoke-unit/sig #t signame unit prefix imports orig))]
[(_ signame unit)
(syntax (do-define-values/invoke-unit/sig #t signame unit #f () orig))]))))
(define-syntax provide-signature-elements
(lambda (stx)
(with-syntax ([orig stx])
(syntax-case stx ()
[(_ signame)
(let ([sig (get-sig 'provide-signature-elements stx #f (syntax signame) (syntax signame))])
(let ([flattened (flatten-signature #f sig (syntax signame))]
[structs (map struct-def-name (signature-structs sig))])
(with-syntax ([flattened (map (lambda (x) (datum->syntax-object (syntax signame) x #f))
(append flattened structs))])
(syntax/loc stx
(provide . flattened)))))]))))
(define (unit/sig? x) (signed-unit? x))
(define (unit/sig->unit x) (signed-unit-unit x))
(provide define-signature
let-signature
unit/sig
compound-unit/sig
invoke-unit/sig
unit->unit/sig
signature->symbols
verify-signature-match
verify-linkage-signature-match
(struct signed-unit (unit imports exports))
unit/sig? unit/sig->unit
define-values/invoke-unit/sig
namespace-variable-bind/invoke-unit/sig
provide-signature-elements))

359
collects/mzlib/unitsig200.ss Normal file
View File

@ -0,0 +1,359 @@
;; This implementation of `unit/sig' was ported from the old v100
;; implementation, and then hacked a bit to produce more compact
;; output, and finally mangled to handle the v200 `struct' (with
;; compile-time information). It's in dire need of an overhaul.
(module unitsig200 mzscheme
(require "unit200.ss")
(require "private/sigmatch.ss")
(require-for-syntax "private/sigutil.ss")
(require-for-syntax "private/sigmatch.ss")
(require-for-syntax (lib "kerncase.ss" "syntax"))
(define-struct signed-unit (unit imports exports))
(define-syntax define-signature
(lambda (expr)
(syntax-case expr ()
[(_ name sig)
(identifier? (syntax name))
(let ([sig (get-sig 'define-signature expr (syntax-e (syntax name))
(syntax sig) #f)])
(with-syntax ([content (explode-sig sig #f)])
(syntax (define-syntax name
(make-sig (quote content))))))])))
(define-syntax let-signature
(lambda (expr)
(syntax-case expr ()
[(_ name sig . body)
(identifier? (syntax name))
(let ([sig (get-sig 'let-signature expr (syntax-e (syntax name))
(syntax sig) #f)])
(with-syntax ([content (explode-sig sig #f)])
(syntax (letrec-syntax ([name (make-sig (quote content))])
. body))))])))
(define-syntax unit/sig
(lambda (expr)
(syntax-case expr ()
[(_ sig . rest)
(let ([sig (get-sig 'unit/sig expr #f (syntax sig) #f)])
(let ([a-unit (parse-unit expr (syntax rest) sig
(kernel-form-identifier-list (quote-syntax here))
(quote-syntax define-values)
(quote-syntax define-syntaxes)
(quote-syntax begin))])
(check-signature-unit-body sig a-unit (parsed-unit-renames a-unit) 'unit/sig expr)
(with-syntax ([imports (parsed-unit-import-vars a-unit)]
[exports (datum->syntax-object
expr
(let ([vars (make-hash-table)])
(for-each (lambda (var)
(hash-table-put! vars (syntax-e var) var))
(parsed-unit-vars a-unit))
(map
(lambda (name)
(list (let ([name (do-rename name (parsed-unit-renames a-unit))])
(hash-table-get vars name name))
name))
(signature-vars sig)))
expr)]
[body (append
(reverse! (parsed-unit-body a-unit))
((parsed-unit-stx-checks a-unit) expr))]
[import-sigs (explode-named-sigs (parsed-unit-imports a-unit) #f)]
[export-sig (explode-sig sig #f)])
(syntax/loc expr
(make-signed-unit
(unit/no-expand
(import . imports)
(export . exports)
. body)
(quote import-sigs)
(quote export-sig))))))])))
(define-syntax compound-unit/sig
(lambda (expr)
(syntax-case expr ()
[(_ . body)
(let-values ([(tags
exprs
exploded-link-imports
exploded-link-exports
flat-imports
link-imports
flat-exports
exploded-imports
exploded-exports
boxed-interned-symbol-vectors)
(parse-compound-unit expr (syntax body))]
[(t) (lambda (l) (datum->syntax-object expr l expr))])
(with-syntax ([(tag ...) (t tags)]
[(uexpr ...) (t exprs)]
[(tagx ...) (t (map (lambda (t) (string->symbol (format "u:~a" t))) tags))]
[exploded-link-imports (t exploded-link-imports)]
[exploded-link-exports (t exploded-link-exports)]
[flat-imports (t flat-imports)]
[(link-import ...) (t link-imports)]
[flat-exports (t flat-exports)]
[exploded-imports (t exploded-imports)]
[exploded-exports (t exploded-exports)]
[interned-vectors (t (map (lambda (x) `(,(car x) (quote ,(cadr x))))
(unbox boxed-interned-symbol-vectors)))])
(syntax/loc
expr
(let ([tagx uexpr] ... . interned-vectors)
(alt-verify-linkage-signature-match
'compound-unit/sig
'(tag ...)
(list tagx ...)
`exploded-link-imports
`exploded-link-exports)
;; All checks done. Make the unit:
(make-signed-unit
(compound-unit
(import . flat-imports)
(link [tag ((signed-unit-unit tagx)
. link-import)]
...)
(export . flat-exports))
`exploded-imports
`exploded-exports)))))])))
(define-syntax invoke-unit/sig
(lambda (expr)
(syntax-case expr ()
[(_ u sig ...)
(let ([sigs (parse-invoke-vars 'invoke-unit/sig (syntax (sig ...)) expr)])
(with-syntax ([exploded-sigs (datum->syntax-object
expr
(explode-named-sigs sigs #f)
expr)]
[flat-sigs (datum->syntax-object
expr
(flatten-signatures sigs #f)
expr)])
(syntax/loc
expr
(let ([unt u])
(alt-verify-linkage-signature-match
(quote invoke-unit/sig)
(quote (invoke))
(list unt)
(quote ((#() . #())))
(quote (exploded-sigs)))
(invoke-unit (signed-unit-unit unt)
. flat-sigs)))))])))
(define-syntax unit->unit/sig
(lambda (expr)
(syntax-case expr ()
[(_ e (im-sig ...) ex-sig)
(let ([im-sigs (map (lambda (sig)
(get-sig 'unit->unit/sig expr #f sig #f))
(syntax->list (syntax (im-sig ...))))]
[ex-sig (get-sig 'unit->unit/sig expr #f (syntax ex-sig) #f)])
(with-syntax ([exploded-imports (datum->syntax-object
expr
(explode-named-sigs im-sigs #f)
expr)]
[exploded-exports (datum->syntax-object
expr
(explode-sig ex-sig #f)
expr)])
(syntax
(make-signed-unit
e
(quote exploded-imports)
(quote exploded-exports)))))])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define -verify-linkage-signature-match
(let ([make-exn make-exn:fail:unit]
[p-suffix (lambda (pos) (case pos [(1) 'st][(2) 'nd][(3) 'rd][else 'th]))])
(lambda (who tags units esigs isigs wrapped? unwrap)
(for-each
(lambda (u tag)
(unless (signed-unit? u)
(raise
(make-exn
(string->immutable-string
(format
"~s: expression for \"~s\" is not a signed unit: ~e"
who tag u))
(current-continuation-marks)))))
units tags)
(for-each
(lambda (u tag esig)
(-verify-signature-match
who #f
(format "specified export signature for ~a" tag)
esig
(format "export signature for actual ~a sub-unit" tag)
(signed-unit-exports u)
wrapped? unwrap))
units tags esigs)
(for-each
(lambda (u tag isig)
(let ([n (length (signed-unit-imports u))]
[c (length isig)])
(unless (= c n)
(raise
(make-exn
(string->immutable-string
(format
"~s: ~a unit imports ~a units, but ~a units were provided"
who tag n c))
(current-continuation-marks))))))
units tags isigs)
(for-each
(lambda (u tag isig)
(let loop ([isig isig][expecteds (signed-unit-imports u)][pos 1])
(unless (null? isig)
(let ([expected (car expecteds)]
[provided (car isig)])
(-verify-signature-match
who #t
(format "~a unit's ~s~s import (which is ~a)" tag
pos (p-suffix pos)
(car expected))
(cdr expected)
(format "~a's ~s~s linkage (which is ~a)"
tag
pos (p-suffix pos)
(car provided))
(cdr provided)
wrapped? unwrap)
(loop (cdr isig) (cdr expecteds) (add1 pos))))))
units tags isigs))))
(define verify-linkage-signature-match
(lambda (who tags units esigs isigs)
(-verify-linkage-signature-match who tags units esigs isigs values values)))
(define alt-verify-linkage-signature-match
(lambda (who tags units esigs isigs)
(-verify-linkage-signature-match who tags units esigs isigs pair? car)))
(define-syntax signature->symbols
(lambda (stx)
(syntax-case stx ()
[(_ name)
(identifier? (syntax name))
(let ([sig (get-sig 'signature->symbols stx #f (syntax name) #f)])
(with-syntax ([e (let cleanup ([p (explode-sig sig #f)])
;; Strip struct info:
(list->vector
(map (lambda (i)
(if (symbol? i)
i
(cons (car i) (cleanup (cdr i)))))
(vector->list (car p)))))])
(syntax 'e)))])))
;; Internal:
(define-syntax do-define-values/invoke-unit/sig
(lambda (stx)
(syntax-case stx ()
[(_ global? signame unite prefix imports orig)
(let* ([formname (if (syntax-e (syntax global?))
'namespace-variable-bind/invoke-unit/sig
'define-values/invoke-unit/sig)]
[badsyntax (lambda (s why)
(raise-syntax-error
#f
(format "bad syntax (~a)" why)
(syntax orig)
s))])
(unless (or (not (syntax-e (syntax prefix)))
(identifier? (syntax prefix)))
(badsyntax (syntax prefix) "prefix is not an identifier"))
(let ([ex-sig (get-sig formname (syntax orig) #f (syntax signame) (syntax signame))])
(let ([ex-exploded (explode-sig ex-sig #f)]
[ex-flattened (flatten-signature #f ex-sig #'signame)])
(let ([im-sigs
(parse-invoke-vars formname (syntax imports) (syntax orig))])
(let ([im-explodeds (explode-named-sigs im-sigs #f)]
[im-flattened (flatten-signatures im-sigs #f)]
[d->s (lambda (x) (datum->syntax-object (syntax orig) x (syntax orig)))])
(with-syntax ([dv/iu (if (syntax-e (syntax global?))
(quote-syntax namespace-variable-bind/invoke-unit)
(quote-syntax define-values/invoke-unit))]
[ex-flattened ex-flattened]
[ex-exploded (d->s ex-exploded)]
[im-explodeds (d->s im-explodeds)]
[im-flattened (d->s im-flattened)]
[formname formname]
[stx-decls (if (syntax-e (syntax global?))
null
(make-struct-stx-decls ex-sig #f #f (syntax signame) #f))])
(syntax/loc stx
(begin
(dv/iu
ex-flattened
(let ([unit-var unite])
(alt-verify-linkage-signature-match
'formname
'(invoke)
(list unit-var)
'(ex-exploded)
'(im-explodeds))
(signed-unit-unit unit-var))
prefix
. im-flattened)
. stx-decls))))))))])))
(define-syntax define-values/invoke-unit/sig
(lambda (stx)
(with-syntax ([orig stx])
(syntax-case stx ()
[(_ signame unit prefix . imports)
(syntax (do-define-values/invoke-unit/sig #f signame unit prefix imports orig))]
[(_ signame unit)
(syntax (do-define-values/invoke-unit/sig #f signame unit #f () orig))]))))
(define-syntax namespace-variable-bind/invoke-unit/sig
(lambda (stx)
(with-syntax ([orig stx])
(syntax-case stx ()
[(_ signame unit prefix . imports)
(syntax (do-define-values/invoke-unit/sig #t signame unit prefix imports orig))]
[(_ signame unit)
(syntax (do-define-values/invoke-unit/sig #t signame unit #f () orig))]))))
(define-syntax provide-signature-elements
(lambda (stx)
(with-syntax ([orig stx])
(syntax-case stx ()
[(_ signame)
(let ([sig (get-sig 'provide-signature-elements stx #f (syntax signame) (syntax signame))])
(let ([flattened (flatten-signature #f sig (syntax signame))]
[structs (map struct-def-name (signature-structs sig))])
(with-syntax ([flattened (map (lambda (x) (datum->syntax-object (syntax signame) x #f))
(append flattened structs))])
(syntax/loc stx
(provide . flattened)))))]))))
(define (unit/sig? x) (signed-unit? x))
(define (unit/sig->unit x) (signed-unit-unit x))
(provide define-signature
let-signature
unit/sig
compound-unit/sig
invoke-unit/sig
unit->unit/sig
signature->symbols
verify-signature-match
verify-linkage-signature-match
(struct signed-unit (unit imports exports))
unit/sig? unit/sig->unit
define-values/invoke-unit/sig
namespace-variable-bind/invoke-unit/sig
provide-signature-elements))

18
collects/net/base64-sig.ss
View File

@ -1,13 +1,7 @@
(module base64-sig (lib "a-signature.ss")
(module base64-sig mzscheme base64-filename-safe
(require (lib "unitsig.ss")) base64-encode-stream
base64-decode-stream
(provide net:base64^) base64-encode
base64-decode)
(define-signature net:base64^
(base64-filename-safe
base64-encode-stream
base64-decode-stream
base64-encode
base64-decode)))

14
collects/net/base64-unit.ss
View File

@ -1,14 +1,8 @@
(module base64-unit (lib "a-unit.ss")
(module base64-unit mzscheme
(require (lib "unitsig.ss"))
(require "base64-sig.ss") (require "base64-sig.ss")
(provide net:base64@) (import)
(define net:base64@ (export base64^)
(unit/sig net:base64^
(import)
(define base64-digit (make-vector 256)) (define base64-digit (make-vector 256))
(let loop ([n 0]) (let loop ([n 0])
@ -142,5 +136,5 @@
(let ([s (open-output-bytes)]) (let ([s (open-output-bytes)])
(base64-encode-stream (open-input-bytes src) s (base64-encode-stream (open-input-bytes src) s
(bytes 13 10)) (bytes 13 10))
(get-output-bytes s)))))) (get-output-bytes s))))

51
collects/net/cgi-sig.ss
View File

@ -1,30 +1,23 @@
(module cgi-sig (lib "a-signature.ss")
(module cgi-sig mzscheme ;; -- exceptions raised --
(require (lib "unitsig.ss")) (struct cgi-error ())
(struct incomplete-%-suffix (chars))
(provide net:cgi^) (struct invalid-%-suffix (char))
(define-signature net:cgi^ ;; -- cgi methods --
( get-bindings
;; -- exceptions raised -- get-bindings/post
(struct cgi-error ()) get-bindings/get
(struct incomplete-%-suffix (chars)) output-http-headers
(struct invalid-%-suffix (char)) generate-html-output
generate-error-output
;; -- cgi methods -- bindings-as-html
get-bindings extract-bindings
get-bindings/post extract-binding/single
get-bindings/get get-cgi-method
output-http-headers
generate-html-output ;; -- general HTML utilities --
generate-error-output string->html
bindings-as-html generate-link-text
extract-bindings )
extract-binding/single
get-cgi-method
;; -- general HTML utilities --
string->html
generate-link-text
)))

13
collects/net/cgi-unit.ss
View File

@ -1,10 +1,9 @@
(module cgi-unit mzscheme (module cgi-unit (lib "a-unit.ss")
(require (lib "unitsig.ss") "cgi-sig.ss" (lib "etc.ss")) (require (lib "etc.ss")
"cgi-sig.ss")
(provide net:cgi@) (import)
(define net:cgi@ (export cgi^)
(unit/sig net:cgi^
(import)
;; type bindings = list ((symbol . string)) ;; type bindings = list ((symbol . string))
@ -239,5 +238,5 @@
(define (generate-link-text url anchor-text) (define (generate-link-text url anchor-text)
(string-append "<a href=\"" url "\">" anchor-text "</a>")) (string-append "<a href=\"" url "\">" anchor-text "</a>"))
))) )

33
collects/net/cookie-sig.ss
View File

@ -1,19 +1,16 @@
(module cookie-sig mzscheme (module cookie-sig (lib "a-signature.ss")
(require (lib "unitsig.ss"))
(provide net:cookie^)
(define-signature net:cookie^ set-cookie
(set-cookie cookie:add-comment
cookie:add-comment cookie:add-domain
cookie:add-domain cookie:add-max-age
cookie:add-max-age cookie:add-path
cookie:add-path cookie:secure
cookie:secure cookie:version
cookie:version ;; To actually return a cookie (string formated as a cookie):
;; To actually return a cookie (string formated as a cookie): print-cookie
print-cookie ;; To parse the Cookies header:
;; To parse the Cookies header: get-cookie
get-cookie get-cookie/single
get-cookie/single ;; exceptions
;; exceptions (struct cookie-error ()))
(struct cookie-error ()))))

547
collects/net/cookie-unit.ss
View File

@ -47,304 +47,297 @@
;; ;;
;; You should think of this procedures as a `format' for cookies. ;; You should think of this procedures as a `format' for cookies.
(module cookie-unit mzscheme (module cookie-unit (lib "a-unit.ss")
(require (lib "unitsig.ss") (require (lib "etc.ss")
(lib "etc.ss")
(lib "list.ss") (lib "list.ss")
(lib "string.ss" "srfi" "13") (lib "string.ss" "srfi" "13")
(lib "char-set.ss" "srfi" "14") (lib "char-set.ss" "srfi" "14")
"cookie-sig.ss") "cookie-sig.ss")
(provide cookie@) (import)
(export cookie^)
(define-struct cookie (name value comment domain max-age path secure version))
(define-struct (cookie-error exn:fail) ())
;; The syntax for the Set-Cookie response header is
;; set-cookie = "Set-Cookie:" cookies
;; cookies = 1#cookie
;; cookie = NAME "=" VALUE *(";" cookie-av)
;; NAME = attr
;; VALUE = value
;; cookie-av = "Comment" "=" value
;; | "Domain" "=" value
;; | "Max-Age" "=" value
;; | "Path" "=" value
;; | "Secure"
;; | "Version" "=" 1*DIGIT
(define set-cookie
(lambda (name pre-value)
(let ([value (to-rfc2109:value pre-value)])
(unless (rfc2068:token? name)
(raise (build-cookie-error (format "Invalid cookie name: ~a / ~a" name value))))
(make-cookie name value
#f;; comment
#f;; current domain
#f;; at the end of session
#f;; current path
#f;; normal (non SSL)
#f;; default version
))))
;;!
;;
;; (function (print-cookie cookie))
;;
;; (param cookie Cookie-structure "The cookie to return as a string")
;;
;; Formats the cookie contents in a string ready to be appended to a
;; "Set-Cookie: " header, and sent to a client (browser).
(define print-cookie
(lambda (cookie)
(unless (cookie? cookie)
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
(string-join
(filter (lambda (s)
(not (string-null? s)))
(list (format "~a=~a" (cookie-name cookie) (cookie-value cookie))
(let ((c (cookie-comment cookie))) (if c (format "Comment=~a" c) ""))
(let ((d (cookie-domain cookie))) (if d (format "Domain=~a" d) ""))
(let ((age (cookie-max-age cookie))) (if age (format "Max-Age=~a" age) ""))
(let ((p (cookie-path cookie))) (if p (format "Path=~a" p) ""))
(let ((s (cookie-secure cookie))) (if s "Secure" ""))
(let ((v (cookie-version cookie))) (format "Version=~a" (if v v 1)))))
"; ")))
(define cookie:add-comment
(lambda (cookie pre-comment)
(let ([comment (to-rfc2109:value pre-comment)])
(unless (cookie? cookie)
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
(set-cookie-comment! cookie comment)
cookie)))
(define cookie:add-domain
(lambda (cookie domain)
(unless (valid-domain? domain)
(raise (build-cookie-error (format "Invalid domain: ~a" domain))))
(unless (cookie? cookie)
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
(set-cookie-domain! cookie domain)
cookie))
(define cookie:add-max-age
(lambda (cookie seconds)
(unless (and (integer? seconds) (not (negative? seconds)))
(raise (build-cookie-error (format "Invalid Max-Age for cookie: ~a" seconds))))
(unless (cookie? cookie)
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
(set-cookie-max-age! cookie seconds)
cookie))
(define cookie:add-path
(lambda (cookie pre-path)
(let ([path (to-rfc2109:value pre-path)])
(unless (cookie? cookie)
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
(set-cookie-path! cookie path)
cookie)))
(define cookie:secure
(lambda (cookie secure?)
(unless (boolean? secure?)
(raise (build-cookie-error (format "Invalid argument (boolean expected), received: ~a" secure?))))
(unless (cookie? cookie)
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
(set-cookie-secure! cookie secure?)
cookie))
(define cookie:version
(lambda (cookie version)
(unless (integer? version)
(raise (build-cookie-error (format "Unsupported version: ~a" version))))
(unless (cookie? cookie)
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
(set-cookie-version! cookie version)
cookie))
(define cookie@ ;; Parsing the Cookie header:
(unit/sig net:cookie^
(import)
(define-struct cookie (name value comment domain max-age path secure version))
(define-struct (cookie-error exn:fail) ())
;; The syntax for the Set-Cookie response header is
;; set-cookie = "Set-Cookie:" cookies
;; cookies = 1#cookie
;; cookie = NAME "=" VALUE *(";" cookie-av)
;; NAME = attr
;; VALUE = value
;; cookie-av = "Comment" "=" value
;; | "Domain" "=" value
;; | "Max-Age" "=" value
;; | "Path" "=" value
;; | "Secure"
;; | "Version" "=" 1*DIGIT
(define set-cookie
(lambda (name pre-value)
(let ([value (to-rfc2109:value pre-value)])
(unless (rfc2068:token? name)
(raise (build-cookie-error (format "Invalid cookie name: ~a / ~a" name value))))
(make-cookie name value
#f;; comment
#f;; current domain
#f;; at the end of session
#f;; current path
#f;; normal (non SSL)
#f;; default version
))))
;;! (define char-set:all-but=
;; (char-set-difference char-set:full (string->char-set "=")))
;; (function (print-cookie cookie))
;;
;; (param cookie Cookie-structure "The cookie to return as a string")
;;
;; Formats the cookie contents in a string ready to be appended to a
;; "Set-Cookie: " header, and sent to a client (browser).
(define print-cookie
(lambda (cookie)
(unless (cookie? cookie)
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
(string-join
(filter (lambda (s)
(not (string-null? s)))
(list (format "~a=~a" (cookie-name cookie) (cookie-value cookie))
(let ((c (cookie-comment cookie))) (if c (format "Comment=~a" c) ""))
(let ((d (cookie-domain cookie))) (if d (format "Domain=~a" d) ""))
(let ((age (cookie-max-age cookie))) (if age (format "Max-Age=~a" age) ""))
(let ((p (cookie-path cookie))) (if p (format "Path=~a" p) ""))
(let ((s (cookie-secure cookie))) (if s "Secure" ""))
(let ((v (cookie-version cookie))) (format "Version=~a" (if v v 1)))))
"; ")))
(define cookie:add-comment (define char-set:all-but-semicolon
(lambda (cookie pre-comment) (char-set-difference char-set:full (string->char-set ";")))
(let ([comment (to-rfc2109:value pre-comment)])
(unless (cookie? cookie)
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
(set-cookie-comment! cookie comment)
cookie)))
(define cookie:add-domain ;;!
(lambda (cookie domain) ;;
(unless (valid-domain? domain) ;; (function (get-all-results name cookies))
(raise (build-cookie-error (format "Invalid domain: ~a" domain)))) ;;
(unless (cookie? cookie) ;; Auxiliar procedure that returns all values associated with
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie)))) ;; `name' in the association list (cookies).
(set-cookie-domain! cookie domain) (define get-all-results
cookie)) (lambda (name cookies)
(let loop ((c cookies))
(cond ((null? c) ())
(else
(let ((pair (car c)))
(if (string=? name (car pair))
;; found an instance of cookie named `name'
(cons (cadr pair) (loop (cdr c)))
(loop (cdr c)))))))))
(define cookie:add-max-age ;; which tipically looks like: (cookie . "test5=\"5\"; test1=\"1\"; test0=\"0\"; test1=\"20\"")
(lambda (cookie seconds) ;; note that it can be multi-valued: `test1' has values: "1", and "20".
(unless (and (integer? seconds) (not (negative? seconds))) ;; Of course, in the same spirit, we only receive the "string content".
(raise (build-cookie-error (format "Invalid Max-Age for cookie: ~a" seconds)))) (define get-cookie
(unless (cookie? cookie) (lambda (name cookies)
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie)))) (let ((cookies (map (lambda (p)
(set-cookie-max-age! cookie seconds) (map string-trim-both
cookie)) (string-tokenize p char-set:all-but=)))
(string-tokenize cookies char-set:all-but-semicolon))))
(get-all-results name cookies))))
(define cookie:add-path ;;!
(lambda (cookie pre-path) ;;
(let ([path (to-rfc2109:value pre-path)]) ;; (function (get-cookie/single name cookies))
(unless (cookie? cookie) ;;
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie)))) ;; (param name String "The name of the cookie we are looking for")
(set-cookie-path! cookie path) ;; (param cookies String "The string (from the environment) with the content of the cookie header.")
cookie))) ;;
;; Returns the first name associated with the cookie named `name', if any, or #f.
(define cookie:secure (define get-cookie/single
(lambda (cookie secure?) (lambda (name cookies)
(unless (boolean? secure?) (let ((cookies (get-cookie name cookies)))
(raise (build-cookie-error (format "Invalid argument (boolean expected), received: ~a" secure?)))) (and (not (null? cookies))
(unless (cookie? cookie) (car cookies)))))
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
(set-cookie-secure! cookie secure?)
cookie))
(define cookie:version
(lambda (cookie version)
(unless (integer? version)
(raise (build-cookie-error (format "Unsupported version: ~a" version))))
(unless (cookie? cookie)
(raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
(set-cookie-version! cookie version)
cookie))
;; Parsing the Cookie header: ;;;;;
;; Auxiliary procedures
;;;;;
;; token = 1*<any CHAR except CTLs or tspecials>
;;
;; tspecials = "(" | ")" | "<" | ">" | "@"
;; | "," | ";" | ":" | "\" | <">
;; | "/" | "[" | "]" | "?" | "="
;; | "{" | "}" | SP | HT
(define char-set:tspecials
(char-set-union (string->char-set "()<>@,;:\\\"/[]?={}")
char-set:whitespace
(char-set #\tab)))
(define char-set:all-but= (define char-set:control
(char-set-difference char-set:full (string->char-set "="))) (char-set-union char-set:iso-control
(char-set (integer->char 127))));; DEL
(define char-set:token (char-set-difference char-set:ascii char-set:tspecials char-set:control))
(define char-set:all-but-semicolon ;; token? : string -> boolean
(char-set-difference char-set:full (string->char-set ";"))) ;;
;; returns #t if s is an RFC 2068 token (see definition above), #f otherwise.
(define rfc2068:token?
(lambda (s) (string-every char-set:token s)))
;;! ;;!
;; ;;
;; (function (get-all-results name cookies)) ;; (function (quoted-string? s))
;; ;;
;; Auxiliar procedure that returns all values associated with ;; (param s String "The string to check")
;; `name' in the association list (cookies). ;;
(define get-all-results ;; Returns s if the string is an RFC 2068 quoted-string, #f otherwise. As in:
(lambda (name cookies) ;; quoted-string = ( <"> *(qdtext) <"> )
(let loop ((c cookies)) ;; qdtext = <any TEXT except <">>
(cond ((null? c) ()) ;;
(else ;; The backslash character ("\") may be used as a single-character quoting
(let ((pair (car c))) ;; mechanism only within quoted-string and comment constructs.
(if (string=? name (car pair)) ;;
;; found an instance of cookie named `name' ;; quoted-pair = "\" CHAR
(cons (cadr pair) (loop (cdr c))) ;;
(loop (cdr c))))))))) ;; implementation note: I have chosen to use a regular expression rather than
;; a character set for this definition because of two dependencies: CRLF must appear
;; which tipically looks like: (cookie . "test5=\"5\"; test1=\"1\"; test0=\"0\"; test1=\"20\"") ;; as a block to be legal, and " may only appear as \"
;; note that it can be multi-valued: `test1' has values: "1", and "20". (define rfc2068:quoted-string?
;; Of course, in the same spirit, we only receive the "string content". (lambda (s)
(define get-cookie (if (regexp-match #rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$" s)
(lambda (name cookies) s
(let ((cookies (map (lambda (p) #f)))
(map string-trim-both
(string-tokenize p char-set:all-but=)))
(string-tokenize cookies char-set:all-but-semicolon))))
(get-all-results name cookies))))
;;! ;; value: token | quoted-string
;; (define (rfc2109:value? s)
;; (function (get-cookie/single name cookies)) (or (rfc2068:token? s) (rfc2068:quoted-string? s)))
;;
;; (param name String "The name of the cookie we are looking for")
;; (param cookies String "The string (from the environment) with the content of the cookie header.")
;;
;; Returns the first name associated with the cookie named `name', if any, or #f.
(define get-cookie/single
(lambda (name cookies)
(let ((cookies (get-cookie name cookies)))
(and (not (null? cookies))
(car cookies)))))
;; convert-to-quoted : string -> quoted-string?
;; takes the given string as a particular message, and converts the given string to that
;;;;; ;; representatation
;; Auxiliar procedures (define (convert-to-quoted str)
;;;;; (string-append "\"" (regexp-replace* #rx"\"" str "\\\\\"") "\""))
;; token = 1*<any CHAR except CTLs or tspecials> ;; string -> rfc2109:value?
;; (define (to-rfc2109:value s)
;; tspecials = "(" | ")" | "<" | ">" | "@" (cond
;; | "," | ";" | ":" | "\" | <"> [(not (string? s))
;; | "/" | "[" | "]" | "?" | "=" (raise (build-cookie-error (format "Expected string, given: ~e" s)))]
;; | "{" | "}" | SP | HT
(define char-set:tspecials ;; for backwards compatibility, just use the given string if it will work
(char-set-union [(rfc2068:token? s) s]
(string->char-set "()<>@,;:\\\"/[]?={}") [(rfc2068:quoted-string? s) s]
char-set:whitespace
(char-set #\tab))) ;; ... but if it doesn't work (i.e., it's just a normal message) then try
;; to convert it into a representation that will work
(define char-set:control (char-set-union char-set:iso-control [(rfc2068:quoted-string? (convert-to-quoted s))
(char-set (integer->char 127))));; DEL => (λ (x) x)]
(define char-set:token (char-set-difference char-set:ascii char-set:tspecials char-set:control)) [else
(raise
;; token? : string -> boolean (build-cookie-error
;; (format "Could not convert the given string to an acceptable RFC 2109 value: ~s" s)))]))
;; returns #t if s is an RFC 2068 token (see definition above), #f otherwise.
(define rfc2068:token? ;;!
(lambda (s) (string-every char-set:token s))) ;;
;; (function (cookie-string? s))
;;! ;;
;; ;; (param s String "String to check")
;; (function (quoted-string? s)) ;;
;; ;; Returns whether this is a valid string to use as the value or the
;; (param s String "The string to check") ;; name (depending on value?) of an HTTP cookie.
;; (define cookie-string?
;; Returns s if the string is an RFC 2068 quoted-string, #f otherwise. As in: (opt-lambda (s (value? #t))
;; quoted-string = ( <"> *(qdtext) <"> ) (unless (string? s)
;; qdtext = <any TEXT except <">> (raise (build-cookie-error (format "String expected, received: ~a" s))))
;; (if value?
;; The backslash character ("\") may be used as a single-character quoting (rfc2109:value? s)
;; mechanism only within quoted-string and comment constructs. ;; name: token
;; (rfc2068:token? s))))
;; quoted-pair = "\" CHAR
;; ;; Host names as per RFC 1123 and RFC952, more or less, anyway. :-)
;; implementation note: I have chosen to use a regular expression rather than (define char-set:hostname
;; a character set for this definition because of two dependencies: CRLF must appear (let ((a-z-lowercase (ucs-range->char-set #x61 #x7B))
;; as a block to be legal, and " may only appear as \" (a-z-uppercase (ucs-range->char-set #x41 #x5B)))
(define rfc2068:quoted-string? (char-set-adjoin!
(lambda (s) (char-set-union char-set:digit a-z-lowercase a-z-uppercase)
(if (regexp-match #rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$" s) #\. )))
s
#f))) (define valid-domain?
(lambda (dom)
;; value: token | quoted-string (and
(define (rfc2109:value? s) ;; Domain must start with a dot (.)
(or (rfc2068:token? s) (rfc2068:quoted-string? s))) (string=? (string-take dom 1) ".")
;; The rest are tokens-like strings separated by dots
;; convert-to-quoted : string -> quoted-string? (string-every char-set:hostname dom)
;; takes the given string as a particular message, and converts the given string to that (<= (string-length dom) 76))))
;; representatation
(define (convert-to-quoted str) (define (valid-path? v)
(string-append "\"" (regexp-replace* #rx"\"" str "\\\\\"") "\"")) (and (string? v)
(rfc2109:value? v)))
;; string -> rfc2109:value?
(define (to-rfc2109:value s) ;; build-cookie-error : string -> cookie-error
(cond ;; constructs a cookie-error struct from the given error message
[(not (string? s)) ;; (added to fix exceptions-must-take-immutable-strings bug)
(raise (build-cookie-error (format "Expected string, given: ~e" s)))] (define (build-cookie-error msg)
(make-cookie-error (string->immutable-string msg)
; for backwards compatibility, just use the given string if it will work (current-continuation-marks)))
[(rfc2068:token? s) s]
[(rfc2068:quoted-string? s) s]
; ... but if it doesn't work (i.e., it's just a normal message) then try to
; convert it into a representation that will work
[(rfc2068:quoted-string? (convert-to-quoted s))
=> (λ (x) x)]
[else
(raise
(build-cookie-error
(format "Could not convert the given string to an acceptable RFC 2109 value: ~s" s)))]))
;;!
;;
;; (function (cookie-string? s))
;;
;; (param s String "String to check")
;;
;; Returns whether this is a valid string to use as the value or the
;; name (depending on value?) of an HTTP cookie.
(define cookie-string?
(opt-lambda (s (value? #t))
(unless (string? s)
(raise (build-cookie-error (format "String expected, received: ~a" s))))
(if value?
(rfc2109:value? s)
;; name: token
(rfc2068:token? s))))
;; Host names as per RFC 1123 and RFC952, more or less, anyway. :-)
(define char-set:hostname
(let ((a-z-lowercase (ucs-range->char-set #x61 #x7B))
(a-z-uppercase (ucs-range->char-set #x41 #x5B)))
(char-set-adjoin!
(char-set-union char-set:digit a-z-lowercase a-z-uppercase)
#\. )))
(define valid-domain?
(lambda (dom)
(and
;; Domain must start with a dot (.)
(string=? (string-take dom 1) ".")
;; The rest are tokens-like strings separated by dots
(string-every char-set:hostname dom)
(<= (string-length dom) 76))))
(define (valid-path? v)
(and (string? v)
(rfc2109:value? v)))
;; build-cookie-error : string -> cookie-error
;; constructs a cookie-error struct from the given error message
;; (added to fix exceptions-must-take-immutable-strings bug)
(define (build-cookie-error msg)
(make-cookie-error (string->immutable-string msg) (current-continuation-marks)))))
) )
;;; cookie-unit.ss ends here ;;; cookie-unit.ss ends here

16
collects/net/dns-sig.ss
View File

@ -1,12 +1,6 @@
(module dns-sig (lib "a-signature.ss")
(module dns-sig mzscheme dns-get-address
(require (lib "unitsig.ss")) dns-get-name
dns-get-mail-exchanger
(provide net:dns^) dns-find-nameserver)
(define-signature net:dns^
(dns-get-address
dns-get-name
dns-get-mail-exchanger
dns-find-nameserver)))

22
collects/net/dns-unit.ss
View File

@ -1,18 +1,14 @@
(module dns-unit (lib "a-unit.ss")
(require (lib "list.ss")
(lib "process.ss")
"dns-sig.ss")
(module dns-unit mzscheme
(require (lib "unitsig.ss")
(lib "list.ss")
(lib "process.ss"))
(require "dns-sig.ss") (import)
(export dns^)
;; UDP retry timeout: ;; UDP retry timeout:
(define INIT-TIMEOUT 50) (define INIT-TIMEOUT 50)
(provide net:dns@)
(define net:dns@
(unit/sig net:dns^
(import)
(define types (define types
'((a 1) '((a 1)
@ -365,5 +361,5 @@
line)) line))
=> (lambda (m) (loop name (cadr m) #f))] => (lambda (m) (loop name (cadr m) #f))]
[else (loop name ip #f)]))))))] [else (loop name ip #f)]))))))]
[else #f]))))) [else #f])))

19
collects/net/ftp-sig.ss
View File

@ -1,13 +1,8 @@
(module ftp-sig mzscheme (module ftp-sig (lib "a-signature.ss")
(require (lib "unitsig.ss")) ftp-cd
ftp-establish-connection ftp-establish-connection*
(provide net:ftp^) ftp-close-connection
ftp-directory-list
(define-signature net:ftp^ ftp-download-file
(ftp-cd ftp-make-file-seconds)
ftp-establish-connection ftp-establish-connection*
ftp-close-connection
ftp-directory-list
ftp-download-file
ftp-make-file-seconds)))

14
collects/net/ftp-unit.ss
View File

@ -1,4 +1,4 @@
(module ftp-unit mzscheme (module ftp-unit (lib "a-unit.ss")
;; Version 0.2 ;; Version 0.2
;; Version 0.1a ;; Version 0.1a
;; Micah Flatt ;; Micah Flatt
@ -6,13 +6,9 @@
(require (lib "date.ss") (require (lib "date.ss")
(lib "file.ss") (lib "file.ss")
(lib "port.ss") (lib "port.ss")
"ftp-sig.ss" "ftp-sig.ss")
(lib "unitsig.ss")) (import)
(export ftp^)
(provide net:ftp@)
(define net:ftp@
(unit/sig net:ftp^
(import)
;; opqaue record to represent an FTP connection: ;; opqaue record to represent an FTP connection:
(define-struct tcp-connection (in out)) (define-struct tcp-connection (in out))
@ -216,4 +212,4 @@
(rename-file-or-directory tmpfile (build-path folder filename) #t))) (rename-file-or-directory tmpfile (build-path folder filename) #t)))
;; (printf "FTP Client Installed...~n") ;; (printf "FTP Client Installed...~n")
))) )

31
collects/net/head-sig.ss
View File

@ -1,19 +1,14 @@
(module head-sig (lib "a-signature.ss")
(module head-sig mzscheme empty-header
(require (lib "unitsig.ss")) validate-header
extract-field
(provide net:head^) remove-field
(define-signature net:head^ insert-field
(empty-header replace-field
validate-header extract-all-fields
extract-field append-headers
remove-field standard-message-header
insert-field data-lines->data
replace-field extract-addresses
extract-all-fields assemble-address-field)
append-headers
standard-message-header
data-lines->data
extract-addresses
assemble-address-field)))

19
collects/net/head-unit.ss
View File

@ -1,16 +1,11 @@
(module head-unit (lib "a-unit.ss")
(require (lib "date.ss")
(lib "string.ss")
"head-sig.ss")
(module head-unit mzscheme (import)
(require (lib "unitsig.ss") (export head^)
(lib "date.ss")
(lib "string.ss"))
(require "head-sig.ss")
(provide net:head@)
(define net:head@
(unit/sig net:head^
(import)
;; NB: I've done a copied-code adaptation of a number of these definitions into ;; NB: I've done a copied-code adaptation of a number of these definitions into
;; "bytes-compatible" versions. Finishing the rest will require some kind of interface ;; "bytes-compatible" versions. Finishing the rest will require some kind of interface
;; decision---that is, when you don't supply a header, should the resulting operation ;; decision---that is, when you don't supply a header, should the resulting operation
@ -402,4 +397,4 @@
alen) alen)
(loop (cdr addresses) (loop (cdr addresses)
(format "~a, ~a" s addr) (format "~a, ~a" s addr)
(+ len alen 2))))))))))) (+ len alen 2)))))))))

80
collects/net/imap-sig.ss
View File

@ -1,44 +1,38 @@
(module imap-sig (lib "a-signature.ss")
imap-port-number
(module imap-sig mzscheme imap-connection?
(require (lib "unitsig.ss"))
imap-connect imap-connect*
(provide net:imap^) imap-disconnect
(define-signature net:imap^ imap-force-disconnect
(imap-port-number imap-reselect
imap-connection? imap-examine
imap-noop
imap-connect imap-connect* imap-status
imap-disconnect imap-poll
imap-force-disconnect
imap-reselect imap-new?
imap-examine imap-messages
imap-noop imap-recent
imap-status imap-uidnext
imap-poll imap-uidvalidity
imap-unseen
imap-new? imap-reset-new!
imap-messages
imap-recent imap-get-expunges
imap-uidnext imap-pending-expunges?
imap-uidvalidity imap-get-updates
imap-unseen imap-pending-updates?
imap-reset-new!
imap-get-messages
imap-get-expunges imap-copy imap-append
imap-pending-expunges? imap-store imap-flag->symbol symbol->imap-flag
imap-get-updates imap-expunge
imap-pending-updates?
imap-mailbox-exists?
imap-get-messages imap-create-mailbox
imap-copy imap-append
imap-store imap-flag->symbol symbol->imap-flag imap-list-child-mailboxes
imap-expunge imap-mailbox-flags
imap-get-hierarchy-delimiter)
imap-mailbox-exists?
imap-create-mailbox
imap-list-child-mailboxes
imap-mailbox-flags
imap-get-hierarchy-delimiter)))

14
collects/net/imap-unit.ss
View File

@ -1,14 +1,10 @@
(module imap-unit (lib "a-unit.ss")
(module imap-unit mzscheme (require (lib "list.ss")
(require (lib "unitsig.ss")
(lib "list.ss")
"imap-sig.ss" "imap-sig.ss"
"private/rbtree.ss") "private/rbtree.ss")
(provide net:imap@) (import)
(define net:imap@ (export imap^)
(unit/sig net:imap^
(import)
(define debug-via-stdio? #f) (define debug-via-stdio? #f)
@ -572,4 +568,4 @@
(cons (cons
(list flags name) (list flags name)
sub-folders)))))))) sub-folders))))))))
(reverse sub-folders)))))) (reverse sub-folders))))

57
collects/net/mime-sig.ss
View File

@ -1,33 +1,26 @@
(module mime-sig mzscheme (module mime-sig (lib "a-signature.ss")
(require (lib "unitsig.ss")) ;; -- exceptions raised --
(struct mime-error () -setters -constructor)
(provide net:mime^) (struct unexpected-termination (msg) -setters -constructor)
(struct missing-multipart-boundary-parameter () -setters -constructor)
(struct malformed-multipart-entity (msg) -setters -constructor)
(struct empty-mechanism () -setters -constructor)
(struct empty-type () -setters -constructor)
(struct empty-subtype () -setters -constructor)
(struct empty-disposition-type () -setters -constructor)
(define-signature net:mime^ ;; -- basic mime structures --
( (struct message (version entity fields))
;; -- exceptions raised -- (struct entity
(struct mime-error () -setters (- make-mime-error)) (type subtype charset encoding
(struct unexpected-termination (msg) -setters (- make-unexpected-termination)) disposition params id
(struct missing-multipart-boundary-parameter () -setters description other fields
(- make-missing-multipart-boundary-parameter)) parts body))
(struct malformed-multipart-entity (msg) -setters (- make-malformed-multipart-entity)) (struct disposition
(struct empty-mechanism () -setters (- make-empty-mechanism)) (type filename creation
(struct empty-type () -setters (- make-empty-type)) modification read
(struct empty-subtype () -setters (- make-empty-subtype)) size params))
(struct empty-disposition-type () -setters (- make-empty-disposition-type))
;; -- mime methods --
;; -- basic mime structures -- mime-analyze
(struct message (version entity fields)) )
(struct entity
(type subtype charset encoding
disposition params id
description other fields
parts body))
(struct disposition
(type filename creation
modification read
size params))
;; -- mime methods --
mime-analyze
)))

13
collects/net/mime-unit.ss
View File

@ -27,23 +27,18 @@
;; Commentary: MIME support for PLT Scheme: an implementation of ;; Commentary: MIME support for PLT Scheme: an implementation of
;; rfc2045, rfc2046, rfc2047, rfc2048, and rfc2049. ;; rfc2045, rfc2046, rfc2047, rfc2048, and rfc2049.
(module mime-unit mzscheme (module mime-unit (lib "a-unit.ss")
(require "mime-sig.ss" (require "mime-sig.ss"
"qp-sig.ss" "qp-sig.ss"
"base64-sig.ss" "base64-sig.ss"
"head-sig.ss" "head-sig.ss"
"mime-util.ss" "mime-util.ss"
(lib "unitsig.ss")
(lib "etc.ss") (lib "etc.ss")
(lib "string.ss") (lib "string.ss")
(lib "port.ss")) (lib "port.ss"))
(provide net:mime@) (import base64^ qp^ head^)
(define net:mime@ (export mime^)
(unit/sig net:mime^
(import net:base64^
net:qp^
net:head^)
;; Constants: ;; Constants:
(define discrete-alist '(("text" . text) (define discrete-alist '(("text" . text)
@ -783,4 +778,4 @@
(define disp-quoted-data-time date-time) (define disp-quoted-data-time date-time)
))) )

40
collects/net/nntp-sig.ss
View File

@ -1,26 +1,20 @@
(module nntp-sig (lib "a-signature.ss")
(module nntp-sig mzscheme (struct communicator (sender receiver server port))
(require (lib "unitsig.ss")) connect-to-server connect-to-server* disconnect-from-server
authenticate-user open-news-group
(provide net:nntp^) head-of-message body-of-message
newnews-since generic-message-command
make-desired-header extract-desired-headers
(define-signature net:nntp^ (struct nntp ())
((struct communicator (sender receiver server port)) (struct unexpected-response (code text))
connect-to-server connect-to-server* disconnect-from-server (struct bad-status-line (line))
authenticate-user open-news-group (struct premature-close (communicator))
head-of-message body-of-message (struct bad-newsgroup-line (line))
newnews-since generic-message-command (struct non-existent-group (group))
make-desired-header extract-desired-headers (struct article-not-in-group (article))
(struct no-group-selected ())
(struct nntp ()) (struct article-not-found (article))
(struct unexpected-response (code text)) (struct authentication-rejected ()))
(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))
(struct authentication-rejected ()))))

16
collects/net/nntp-unit.ss
View File

@ -1,13 +1,9 @@
(module nntp-unit mzscheme (module nntp-unit (lib "a-unit.ss")
(require (lib "unitsig.ss") (require (lib "etc.ss")
(lib "etc.ss")) "nntp-sig.ss")
(require "nntp-sig.ss") (import)
(export nntp^)
(provide net:nntp@)
(define net:nntp@
(unit/sig net:nntp^
(import)
;; sender : oport ;; sender : oport
;; receiver : iport ;; receiver : iport
@ -337,5 +333,5 @@
(regexp-match matcher first)) (regexp-match matcher first))
desireds) desireds)
(cons first (loop rest)) (cons first (loop rest))
(loop rest)))))))))) (loop rest))))))))

46
collects/net/pop3-sig.ss
View File

@ -1,27 +1,21 @@
(module pop3-sig (lib "a-signature.ss")
(module pop3-sig mzscheme (struct communicator (sender receiver server port state))
(require (lib "unitsig.ss")) connect-to-server connect-to-server* disconnect-from-server
authenticate/plain-text
(provide net:pop3^) get-mailbox-status
get-message/complete get-message/headers get-message/body
delete-message
get-unique-id/single get-unique-id/all
(define-signature net:pop3^ make-desired-header extract-desired-headers
((struct communicator (sender receiver server port state))
connect-to-server connect-to-server* disconnect-from-server (struct pop3 ())
authenticate/plain-text (struct cannot-connect ())
get-mailbox-status (struct username-rejected ())
get-message/complete get-message/headers get-message/body (struct password-rejected ())
delete-message (struct not-ready-for-transaction (communicator))
get-unique-id/single get-unique-id/all (struct not-given-headers (communicator message))
(struct illegal-message-number (communicator message))
make-desired-header extract-desired-headers (struct cannot-delete-message (communicator message))
(struct disconnect-not-quiet (communicator))
(struct pop3 ()) (struct malformed-server-response (communicator)))
(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)))))

17
collects/net/pop3-unit.ss
View File

@ -1,14 +1,9 @@
(module pop3-unit (lib "a-unit.ss")
(require (lib "etc.ss")
"pop3-sig.ss")
(module pop3-unit mzscheme (import)
(require (lib "unitsig.ss") (export pop3^)
(lib "etc.ss"))
(require "pop3-sig.ss")
(provide net:pop3@)
(define net:pop3@
(unit/sig net:pop3^
(import)
;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose ;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose
@ -411,5 +406,5 @@
(regexp-match matcher first)) (regexp-match matcher first))
desireds) desireds)
(cons first (loop rest)) (cons first (loop rest))
(loop rest)))))))))) (loop rest))))))))

27
collects/net/qp-sig.ss
View File

@ -1,17 +1,12 @@
(module qp-sig mzscheme (module qp-sig (lib "a-signature.ss")
(require (lib "unitsig.ss")) ;; -- exceptions raised --
(struct qp-error () -setters -constructor)
(struct qp-wrong-input () -setters -constructor)
(struct qp-wrong-line-size (size) -setters -constructor)
(provide net:qp^) ;; -- qp methods --
(define-signature net:qp^ qp-encode
( qp-decode
;; -- exceptions raised -- qp-encode-stream
(struct qp-error () -setters (- make-qp-error)) qp-decode-stream
(struct qp-wrong-input () -setters (- make-qp-wrong-input)) )
(struct qp-wrong-line-size (size) -setters (- make-qp-wrong-line-size))
;; -- qp methods --
qp-encode
qp-decode
qp-encode-stream
qp-decode-stream
)))

11
collects/net/qp-unit.ss
View File

@ -25,15 +25,12 @@
;; ;;
;; Commentary: ;; Commentary:
(module qp-unit mzscheme (module qp-unit (lib "a-unit.ss")
(require "qp-sig.ss" (require "qp-sig.ss"
(lib "unitsig.ss")
(lib "etc.ss")) (lib "etc.ss"))
(provide net:qp@) (import)
(define net:qp@ (export qp^)
(unit/sig net:qp^
(import)
;; Exceptions: ;; Exceptions:
;; String or input-port expected: ;; String or input-port expected:
@ -171,6 +168,6 @@
(vector-set! hex-values (+ i 65) (+ 10 i)) (vector-set! hex-values (+ i 65) (+ 10 i))
(vector-set! hex-values (+ i 97) (+ 10 i)) (vector-set! hex-values (+ i 97) (+ 10 i))
(vector-set! hex-bytes (+ 10 i) (+ i 65)) (vector-set! hex-bytes (+ 10 i) (+ i 65))
(loop (add1 i))))))) (loop (add1 i)))))
;;; qp-unit.ss ends here ;;; qp-unit.ss ends here

14
collects/net/sendmail-sig.ss
View File

@ -1,11 +1,5 @@
(module sendmail-sig (lib "a-signature.ss")
(module sendmail-sig mzscheme send-mail-message/port
(require (lib "unitsig.ss")) send-mail-message
(struct no-mail-recipients ()))
(provide net:sendmail^)
(define-signature net:sendmail^
(send-mail-message/port
send-mail-message
(struct no-mail-recipients ()))))

17
collects/net/sendmail-unit.ss
View File

@ -1,14 +1,9 @@
(module sendmail-unit (lib "a-unit.ss")
(require (lib "process.ss")
"sendmail-sig.ss")
(module sendmail-unit mzscheme (import)
(require (lib "unitsig.ss") (export sendmail^)
(lib "process.ss"))
(require "sendmail-sig.ss")
(provide net:sendmail@)
(define net:sendmail@
(unit/sig net:sendmail^
(import)
(define-struct (no-mail-recipients exn) ()) (define-struct (no-mail-recipients exn) ())
@ -121,4 +116,4 @@
(display s writer) ; We use -i, so "." is not a problem (display s writer) ; We use -i, so "." is not a problem
(newline writer)) (newline writer))
text) text)
(close-output-port writer))))))) (close-output-port writer)))))

15
collects/net/smtp-sig.ss
View File

@ -1,11 +1,6 @@
(module smtp-sig (lib "a-signature.ss")
(module smtp-sig mzscheme smtp-sending-server
(require (lib "unitsig.ss")) smtp-send-message
smtp-send-message*
(provide net:smtp^) smtp-sending-end-of-message)
(define-signature net:smtp^
(smtp-sending-server
smtp-send-message
smtp-send-message*
smtp-sending-end-of-message)))

19
collects/net/smtp-unit.ss
View File

@ -1,15 +1,10 @@
(module smtp-unit (lib "a-unit.ss")
(require (lib "kw.ss")
"base64.ss"
"smtp-sig.ss")
(module smtp-unit mzscheme (import)
(require (lib "unitsig.ss") (export smtp^)
(lib "kw.ss")
"base64.ss")
(require "smtp-sig.ss")
(provide net:smtp@)
(define net:smtp@
(unit/sig net:smtp^
(import)
(define smtp-sending-server (make-parameter "localhost")) (define smtp-sending-server (make-parameter "localhost"))
@ -133,4 +128,4 @@
(values (current-input-port) (current-output-port)) (values (current-input-port) (current-output-port))
(tcp-connect server opt-port-no))]) (tcp-connect server opt-port-no))])
(smtp-send-message* r w sender recipients header message-lines (smtp-send-message* r w sender recipients header message-lines
auth-user auth-passwd))))))) auth-user auth-passwd)))))

24
collects/net/uri-codec-sig.ss
View File

@ -1,14 +1,10 @@
(module uri-codec-sig mzscheme (module uri-codec-sig (lib "a-signature.ss")
(require (lib "unitsig.ss")) uri-encode
(provide net:uri-codec^) uri-decode
uri-path-segment-encode
(define-signature net:uri-codec^ uri-path-segment-decode
(uri-encode form-urlencoded-encode
uri-decode form-urlencoded-decode
uri-path-segment-encode alist->form-urlencoded
uri-path-segment-decode form-urlencoded->alist
form-urlencoded-encode current-alist-separator-mode)
form-urlencoded-decode
alist->form-urlencoded
form-urlencoded->alist
current-alist-separator-mode)))

16
collects/net/uri-codec-unit.ss
View File

@ -167,21 +167,17 @@ JALQefhDMCATcl2/bZL0bw==
;; Draws inspiration from encode-decode.scm by Kurt Normark and a code ;; Draws inspiration from encode-decode.scm by Kurt Normark and a code
;; sample provided by Eli Barzilay ;; sample provided by Eli Barzilay
(module uri-codec-unit mzscheme (module uri-codec-unit (lib "a-unit.ss")
(require (lib "unitsig.ss") (require (lib "match.ss")
(lib "match.ss")
(lib "string.ss") (lib "string.ss")
(lib "list.ss") (lib "list.ss")
(lib "etc.ss") (lib "etc.ss")
"uri-codec-sig.ss") "uri-codec-sig.ss")
(provide uri-codec@) (import)
(export uri-codec^)
(define uri-codec@
(unit/sig net:uri-codec^
(import)
(define (self-map-char ch) (cons ch ch)) (define (self-map-char ch) (cons ch ch))
(define (self-map-chars str) (map self-map-char (string->list str))) (define (self-map-chars str) (map self-map-char (string->list str)))
@ -375,6 +371,6 @@ JALQefhDMCATcl2/bZL0bw==
(raise-type-error 'current-alist-separator-mode (raise-type-error 'current-alist-separator-mode
"'amp, 'semi, or 'amp-or-semi" "'amp, 'semi, or 'amp-or-semi"
s)) s))
s)))))) s))))
;;; uri-codec-unit.ss ends here ;;; uri-codec-unit.ss ends here

32
collects/net/url-sig.ss
View File

@ -1,19 +1,15 @@
(module url-sig mzscheme (module url-sig (lib "a-signature.ss")
(require (lib "unitsig.ss")) get-pure-port
(provide net:url^) get-impure-port
post-pure-port
(define-signature net:url^ post-impure-port
(get-pure-port display-pure-port
get-impure-port purify-port
post-pure-port netscape/string->url
post-impure-port string->url
display-pure-port url->string
purify-port call/input-url
netscape/string->url combine-url/relative
string->url url-exception?
url->string current-proxy-servers)
call/input-url
combine-url/relative
url-exception?
current-proxy-servers)))

10
collects/net/url-unit.ss
View File

@ -11,7 +11,7 @@
(module url-unit mzscheme (module url-unit mzscheme
(require (lib "file.ss") (require (lib "file.ss")
(lib "unitsig.ss") (lib "unit.ss")
(lib "port.ss") (lib "port.ss")
(lib "string.ss") (lib "string.ss")
(lib "list.ss") (lib "list.ss")
@ -26,9 +26,9 @@
(define url:os-type (system-type)) (define url:os-type (system-type))
(define (set-url:os-type! new) (set! url:os-type new)) (define (set-url:os-type! new) (set! url:os-type new))
(define url@ (define-unit url@
(unit/sig net:url^ (import tcp^)
(import net:tcp^) (export url^)
(define-struct (url-exception exn:fail) ()) (define-struct (url-exception exn:fail) ())
@ -445,4 +445,4 @@
(apply string-append (reverse! r)) (apply string-append (reverse! r))
(loop (cdr strings) (list* (car strings) sep r))))])) (loop (cdr strings) (list* (car strings) sep r))))]))
))) ))

12
collects/tests/mzscheme/pconvert.ss
View File

@ -3,8 +3,7 @@
(Section 'pconvert) (Section 'pconvert)
(require (lib "unit.ss") (require (lib "file.ss")
(lib "file.ss")
(lib "class.ss") (lib "class.ss")
(lib "pconvert.ss")) (lib "pconvert.ss"))
@ -12,7 +11,6 @@
(quasi-read-style-printing #f) (quasi-read-style-printing #f)
(define (xl) 1) (define (xl) 1)
(define (xu) (unit (import) (export)))
(define (xc) (class object% () (sequence (super-init)))) (define (xc) (class object% () (sequence (super-init))))
(let () (let ()
@ -174,7 +172,6 @@
(make-pctest null 'empty 'empty 'empty '`() '`() '`() 'empty) (make-pctest null 'empty 'empty 'empty '`() '`() '`() 'empty)
(make-same-test add1 'add1) (make-same-test add1 'add1)
(make-same-test (void) '(void)) (make-same-test (void) '(void))
(make-same-test (unit (import) (export)) '(unit ...))
(make-same-test (make-weak-box 12) '(make-weak-box 12)) (make-same-test (make-weak-box 12) '(make-weak-box 12))
(make-same-test (regexp "1") '(regexp "1")) (make-same-test (regexp "1") '(regexp "1"))
(make-same-test (module-path-index-join #f #f) '(module-path-index-join false false)) (make-same-test (module-path-index-join #f #f) '(module-path-index-join false false))
@ -190,12 +187,6 @@
(make-same-test (letrec ([xc-ID-BETTER-NOT-BE-DEFINED (class object% ())]) (make-same-test (letrec ([xc-ID-BETTER-NOT-BE-DEFINED (class object% ())])
xc-ID-BETTER-NOT-BE-DEFINED) xc-ID-BETTER-NOT-BE-DEFINED)
'(class ...)) '(class ...))
(make-same-test xu 'xu)
(make-same-test (letrec ([xu (unit (import) (export))]) xu)
'(unit ...))
(make-same-test (letrec ([xu-ID-BETTER-NOT-BE-DEFINED (unit (import) (export))])
xu-ID-BETTER-NOT-BE-DEFINED)
'(unit ...))
(make-same-test (lambda (x) x) '(lambda (a1) ...)) (make-same-test (lambda (x) x) '(lambda (a1) ...))
(make-same-test (lambda x x) '(lambda args ...)) (make-same-test (lambda x x) '(lambda args ...))
(make-same-test (lambda (a b . c) a) '(lambda (a1 a2 . args) ...)) (make-same-test (lambda (a b . c) a) '(lambda (a1 a2 . args) ...))
@ -360,7 +351,6 @@
(test-shared (lambda (x) x) '(lambda (a1) ...)) (test-shared (lambda (x) x) '(lambda (a1) ...))
(test-shared (delay 1) '(delay ...)) (test-shared (delay 1) '(delay ...))
(test-shared (class object% ()) '(class ...)) (test-shared (class object% ()) '(class ...))
(test-shared (unit (import) (export)) '(unit ...))
(test-shared (new (class object% (super-new))) '(instantiate (class ...) ...)) (test-shared (new (class object% (super-new))) '(instantiate (class ...) ...))
(test-shared "abc" "abc") (test-shared "abc" "abc")

2
collects/tests/mzscheme/unit.ss
View File

@ -2,7 +2,7 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(Section 'unit) (Section 'unit)
(require (lib "unit.ss")) (require (lib "unit200.ss"))
(syntax-test #'(unit)) (syntax-test #'(unit))
(syntax-test #'(unit (import))) (syntax-test #'(unit (import)))

4
collects/tests/mzscheme/unitsig.ss
View File

@ -1,8 +1,8 @@
(load-relative "loadtest.ss") (load-relative "loadtest.ss")
(require (lib "unit.ss")) (require (lib "unit200.ss"))
(require (lib "unitsig.ss")) (require (lib "unitsig200.ss"))
(require (lib "include.ss")) (require (lib "include.ss"))
(Section 'unit/sig) (Section 'unit/sig)