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

350.2

Browse Source 
svn: r3496
This commit is contained in:
Matthew Flatt 2006-06-27 12:34:39 +00:00
parent 853feee8d2
commit 6706befaa3
39 changed files with 3449 additions and 3017 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
collects/compiler/private/xform.ss
View File

@ -672,6 +672,7 @@
(printf "#define NULL_OUT_ARRAY(a) memset(a, 0, sizeof(a))~n")
;; Annotation that normally disappears:
(printf "#define GC_CAN_IGNORE /**/~n")
(printf "#define __xform_nongcing__ /**/~n")
;; Another annotation to protect against GC conversion:
(printf "#define HIDE_FROM_XFORM(x) x~n")
(printf "#define HIDE_NOTHING_FROM_XFORM() /**/~n")
@ -830,21 +831,24 @@
non-functions)
ht))
(define non-gcing-functions
(define non-gcing-builtin-functions
;; The following don't need wrappers, but we need to check for
;; nested function calls because it takes more than one argument:
(append
'(memcpy memmove
strcmp strcoll strcpy _mzstrcpy strcat memset
printf sprintf vsprintf vprintf
strncmp scheme_strncmp
read write
bigdig_length)
strncmp
read write)
(map
string->symbol
'("XTextExtents" "XTextExtents16"
"XDrawImageString16" "XDrawImageString"
"XDrawString16" "XDrawString"))))
(define non-gcing-functions (make-hash-table))
(for-each (lambda (name)
(hash-table-put! non-gcing-functions name #t))
non-gcing-builtin-functions)
(define non-returning-functions
;; The following functions never return, so the wrappers
@ -991,7 +995,9 @@
(set! pointer-types (list-ref l 4))
(set! non-pointer-types (list-ref l 5))
(set! struct-defs (list-ref l 6))))
(set! struct-defs (list-ref l 6))
(set! non-gcing-functions (hash-table-copy (list-ref l 7)))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Pretty-printing output
@ -1335,7 +1341,9 @@
e))]
[(proc-prototype? e)
(let ([name (register-proto-information e)])
(when show-info?
(when (eq? (tok-n (car e)) '__xform_nongcing__)
(hash-table-put! non-gcing-functions name #t))
(when show-info?
(printf "/* PROTO ~a */~n" name))
(if (or precompiling-header?
(> (hash-table-get used-symbols name) 1)
@ -1367,6 +1375,8 @@
e))))]
[(function? e)
(let ([name (register-proto-information e)])
(when (eq? (tok-n (car e)) '__xform_nongcing__)
(hash-table-put! non-gcing-functions name #t))
(when show-info? (printf "/* FUNCTION ~a */~n" name))
(if (or (positive? suspend-xform)
(not pgc?)
@ -1587,7 +1597,9 @@
(let ([name (tok-n (car e))]
[type (let loop ([t (reverse type)])
(if (pair? t)
(if (memq (tok-n (car t)) '(extern static inline virtual __stdcall __cdecl _inline __inline __inline__))
(if (memq (tok-n (car t)) '(extern static virtual __stdcall __cdecl
inline _inline __inline __inline__
__xform_nongcing__))
(loop (cdr t))
(cons (car t) (loop (cdr t))))
t))]
@ -2088,6 +2100,7 @@
;; Temporary state used during a conversion:
(define used-self? #f)
(define important-conversion? #f)
(define saw-gcing-call #f)
(define (new-vars->decls vars)
(apply
@ -2186,6 +2199,7 @@
(seq-close body-v)
(let-values ([(orig-body-e) (begin
(set! important-conversion? #f)
(set! saw-gcing-call #f)
body-e)]
[(body-e live-vars)
;; convert-body does most of the conversion work, and also
@ -2247,14 +2261,26 @@
e
(lambda (name class-name type args static?)
type)))])
(if (hash-table-get non-gcing-functions name (lambda () #f))
(when saw-gcing-call
(log-error "[GCING] ~a in ~a: Function ~a declared __xform_nongcing__, but includes a function call."
(tok-line saw-gcing-call) (tok-file saw-gcing-call)
name))
(unless saw-gcing-call
'
(fprintf (current-error-port)
"[SUGGEST] Consider declaring ~a as __xform_nongcing__.\n"
name)))
(if (and (not important-conversion?)
(not (and function-name
(eq? class-name function-name)))
(null? (live-var-info-new-vars live-vars))
(zero? (live-var-info-maxpush live-vars))
(or (<= (live-var-info-num-calls live-vars) 1)
(= (live-var-info-num-calls live-vars)
(live-var-info-num-noreturn-calls live-vars))))
(or (not saw-gcing-call)
(and
(null? (live-var-info-new-vars live-vars))
(zero? (live-var-info-maxpush live-vars))
(or (<= (live-var-info-num-calls live-vars) 1)
(= (live-var-info-num-calls live-vars)
(live-var-info-num-noreturn-calls live-vars))))))
;; No conversion necessary. (Lack of `call' records means no GC-setup
;; work when printing out the function.)
(list->seq
@ -3154,7 +3180,7 @@
[(sub-memcpy?)
;; memcpy, etc. call?
(and (pair? (cdr e-))
(memq (tok-n (cadr e-)) non-gcing-functions))]
(hash-table-get non-gcing-functions (tok-n (cadr e-)) (lambda () #f)))]
[(args live-vars)
(convert-paren-interior args vars &-vars
c++-class
@ -3229,20 +3255,22 @@
(live-var-info-nonempty-calls? live-vars)))])
(loop rest-
(let ([call (if (and (null? (cdr func))
(memq (tok-n (car func)) non-gcing-functions))
(hash-table-get non-gcing-functions (tok-n (car func)) (lambda () #f)))
;; Call without pointer pushes
(make-parens
"(" #f #f ")"
(list->seq (append func (list args))))
;; Call with pointer pushes
(make-call
"func call"
#f #f
func
args
pushed-vars
(live-var-info-tag orig-live-vars)
this-nonempty?))])
(begin
(set! saw-gcing-call (car e-))
(make-call
"func call"
#f #f
func
args
pushed-vars
(live-var-info-tag orig-live-vars)
this-nonempty?)))])
(cons (if (null? setups)
call
(make-callstage-parens
@ -3723,7 +3751,8 @@
(marshall pointer-types)
(marshall non-pointer-types)
(marshall struct-defs))])
(marshall struct-defs)
non-gcing-functions)])
(with-output-to-file (change-suffix file-out #".zo")
(lambda ()
(write (compile e)))

2
collects/help/servlets/release/license.ss
View File

@ -96,4 +96,4 @@
("GNU lightning"
"Copyright (c) 1994, 1995, 1996, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.")
("GNU Classpath"
"Gnu Public Licence with special exception")))))))
"GNU Public License with special exception")))))))

486
collects/honu-module/dynamic.ss
View File

@ -3,23 +3,15 @@
(require-for-syntax (lib "stx.ss" "syntax")
"private/ops.ss"
"private/util.ss"
(lib "kerncase.ss" "syntax"))
(lib "kerncase.ss" "syntax")
"private/contexts.ss")
(begin-for-syntax
(define kernel-forms (kernel-form-identifier-list #'here))
(define (top-block-context? ctx) (memq ctx '(top-block)))
(define (return-block-context? ctx) (memq ctx '(return-block)))
(define (block-context? ctx) (memq ctx '(top-block block return-block)))
(define (expression-context? ctx) (memq ctx '(expression)))
(define (type-context? ctx) (memq ctx '(type)))
(define block-context 'block)
(define return-block-context 'return-block)
(define top-block-context 'top-block)
(define expression-context 'expression)
(define type-context 'type)
(define expand-stop-forms (list* #'honu-typed
#'honu-unparsed-block
kernel-forms))
;; --------------------------------------------------------
;; Transformer procedure property and basic struct
@ -62,6 +54,11 @@
(let ([str (symbol->string (syntax-e stx))])
(and (positive? (string-length str))
(memq (string-ref str 0) sym-chars)))))))
(define (honu-identifier? stx)
(and (identifier? stx)
(not (ormap (lambda (i) (module-identifier=? stx i)) (list #'\; #'\,)))
(not (operator? stx))))
(define (get-transformer stx)
(or (and (stx-pair? stx)
@ -104,21 +101,30 @@
[((#%braces . block) . rest) (cons #'block #'rest)]
[_else #f])
=> (lambda (b+r)
(k #`(honu-unparsed-block #f void-type #f #,(return-block-context? ctx)
(k #`(honu-unparsed-block #f obj #f #,(and (stx-null? (cdr b+r))
(return-block-context? ctx))
#,@(car b+r))
(cdr b+r)))]
[else (let-values ([(expr-stxs after-expr) (extract-until body (list #'\;))])
[else (let-values ([(expr-stxs after-expr terminator) (extract-until body (list #'\;))])
(unless expr-stxs
(raise-syntax-error
#f
"expected a semicolon to terminate form"
(stx-car body)))
(when (null? expr-stxs)
(raise-syntax-error
#f
"missing expression before terminator"
terminator))
(let ([code ((if (return-block-context? ctx)
parse-a-tail-expr
parse-an-expr)
expr-stxs)])
(k ((if (top-block-context? ctx)
(lambda (x) `(printf "~s\n" ,x))
(lambda (x)
`(let ([v ,x])
(unless (void? v)
(printf "~s\n" v))))
values)
code)
(stx-cdr after-expr))))]))
@ -136,12 +142,13 @@
;; Parsing expressions
(define parse-expr
;; The given syntax sequence must not be empty
(let ()
(define (parse-expr-seq stx)
(define (start-expr stx)
(let ([trans (get-transformer stx)])
(if trans
(let-values ([(expr rest) (trans stx expression-context)])
(let-values ([(expr rest) (trans stx the-expression-context)])
(if (stx-null? rest)
(list expr)
(cons expr (start-operator rest))))
@ -169,7 +176,7 @@
#f
"missing expression inside braces"
(stx-car stx))
(list #'(honu-unparsed-block #f void-type #f #f . pexpr)))]
(list #'(honu-unparsed-block #f obj #f #f . pexpr)))]
[(op . more)
(and (identifier? #'op)
(ormap (lambda (uop)
@ -235,19 +242,19 @@
[(prefix? op)
(group (append (reverse (cdr before))
(list (quasisyntax/loc (op-id op)
(#,(op-id op) #,(car before))))
(honu-app #,(op-id op) #,(car before))))
(reverse since)))]
[(postfix? op)
(let ([after (reverse since)])
(group (append (reverse before)
(list (quasisyntax/loc (op-id op)
(#,(op-id op) #,(car after))))
(honu-app #,(op-id op) #,(car after))))
(cdr after))))]
[(infix? op)
(let ([after (reverse since)])
(group (append (reverse (cdr before))
(list (quasisyntax/loc (op-id op)
(#,(op-id op) #,(car before) #,(car after))))
(honu-app #,(op-id op) #,(car before) #,(car after))))
(cdr after))))]
[else (error "not an op!: " op)])]
[(not (op? (stx-car seq)))
@ -265,7 +272,7 @@
(define (parse-arg-list stxs)
(if (stx-null? stxs)
stxs
(let-values ([(val-stxs after-expr) (extract-until stxs (list #'\,))])
(let-values ([(val-stxs after-expr terminator) (extract-until stxs (list #'\,))])
(when (and val-stxs
(stx-null? (stx-cdr after-expr)))
(raise-syntax-error
@ -321,30 +328,30 @@
[where-stx orig-args-stx])
(let-values ([(type rest-stx) (if (syntax-case args-stx (\,)
[(id \, . rest)
(identifier? #'id)
(honu-identifier? #'id)
#t]
[(id)
(identifier? #'id)
(honu-identifier? #'id)
#t]
[_else #f])
(values (make-h-type #'val #'(begin) #'(lambda (x) (values #t x)))
(values (make-h-type #'obj #'(begin) #'(lambda (x) (values #t x)))
args-stx)
(let ([trans (get-transformer args-stx)])
(if trans
(trans args-stx type-context)
(trans args-stx the-type-context)
(values #f #f))))])
(unless (honu-type? type)
(raise-syntax-error
'|procedure declaration|
(format "expected a type ~a" where)
(format "expected an identifier or type ~a, found something else" where)
where-stx))
(syntax-case rest-stx ()
[(id)
(identifier? #'id)
(honu-identifier? #'id)
(parse-one-argument proc-id type #'id
(lambda () null))]
[(id comma . rest)
(and (identifier? #'id)
(and (honu-identifier? #'id)
(identifier? #'comma)
(module-identifier=? #'comma #'\,))
(parse-one-argument proc-id type #'id
@ -353,18 +360,18 @@
"after comma"
#'comma)))]
[(id something . rest)
(identifier? #'id)
(honu-identifier? #'id)
(raise-syntax-error
'procedure\ declaration
"expected a comma after identifier name"
"expected a comma after argument identifier, found something else"
#'something)]
[_else
(raise-syntax-error
'procedure\ declaration
"expected an argument identifier"
"expected an argument identifier, found something else"
(car rest-stx))])))))
(define (make-honu-type pred-id mk-pred-def only-mode)
(define (make-honu-type pred-id mk-pred-def)
(make-honu-trans
(lambda (orig-stx ctx)
(let* ([pred-id (or pred-id
@ -373,17 +380,17 @@
(mk-pred-def pred-id orig-stx)
#'(begin))])
(cond
[(block-context? ctx)
[(or (block-context? ctx)
(definition-context? ctx))
(with-syntax ([pred-id pred-id]
[type-name (stx-car orig-stx)])
(let loop ([stx (stx-cdr orig-stx)]
[after (stx-car orig-stx)]
[after-what "type name"]
[parens-ok? #t])
[after-what "type name"])
(syntax-case stx ()
[(id . rest)
(begin
(unless (identifier? #'id)
(unless (honu-identifier? #'id)
(raise-syntax-error 'declaration
(format "expected a identifier after ~a" after-what)
(stx-car orig-stx)
@ -391,13 +398,13 @@
(if (and (identifier? (stx-car #'rest))
(module-identifier=? #'set! (stx-car #'rest)))
;; -- Non-procedure declaration
(if (eq? 'function only-mode)
(if (function-definition-context? ctx)
(raise-syntax-error
'declaration
"expected parentheses after name for function definition"
(stx-car #'rest))
(let-values ([(val-stxs after-expr) (extract-until (stx-cdr #'rest)
(list #'\; #'\,))])
(let-values ([(val-stxs after-expr terminator) (extract-until (stx-cdr #'rest)
(list #'\; #'\,))])
(unless val-stxs
(raise-syntax-error
'declaration
@ -408,22 +415,23 @@
'declaration
"missing expression initializing assignment"
(stx-car #'rest)))
(let ([def #`(define-typed id #f type-name pred-id
(check-expr #f 'id type-name pred-id
(honu-unparsed-expr #,@val-stxs)))])
(let ([def #`(define-typed id
#,(constant-definition-context? ctx)
#f type-name pred-id
(check-expr-type #f 'id type-name pred-id
(honu-unparsed-expr #,@val-stxs)))])
(if (module-identifier=? #'\; (stx-car after-expr))
(values #`(begin #,pred-def #,def) (stx-cdr after-expr))
(let-values ([(defs remainder kind) (loop (stx-cdr after-expr) (stx-car after-expr) "comma" #f)])
(values #`(begin #,pred-def #,def #,defs) remainder))))))
;; -- Procedure declaration
(if (eq? 'var only-mode)
(if (value-definition-context? ctx)
(raise-syntax-error
'declaration
"expected = after name for variable"
(format "expected = after name in ~a context" (context->name ctx))
(stx-car #'rest))
(syntax-case #'rest (#%parens \;)
[((#%parens . prest) (#%braces . body) . rest)
parens-ok?
(let ([args (parse-arguments #'prest #'id)])
(with-syntax ([((arg arg-type arg-pred-def arg-pred-id) ...) args]
[(temp-id ...) (generate-temporaries (map car args))])
@ -431,14 +439,14 @@
#,pred-def
arg-pred-def ...
(define-typed-procedure id
type-name
((arg arg-type arg-pred-id) ...)
(lambda (temp-id ...)
(define-typed arg id arg-type arg-pred-id temp-id) ...
(define-typed arg #f id arg-type arg-pred-id temp-id) ...
(honu-unparsed-block id type-name pred-id #t . body))))
#'rest)))]
;; --- Error handling ---
[((#%parens . prest) . bad-rest)
parens-ok?
(begin
(parse-arguments #'prest #'id)
(raise-syntax-error
@ -446,30 +454,26 @@
"braces for function body after parenthesized arguments"
(stx-car #'rest)
#'id))]
[_else
[(id . _)
(raise-syntax-error
'|declaration|
(if parens-ok?
"expected either = (for variable intialization) or parens (for function arguments)"
"expected = (for variable initialization)")
(cond
[(constant-definition-context? ctx) "expected = (for constant initialization)"]
[(variable-definition-context? ctx) "expected = (for variable initialization)"]
[(function-definition-context? ctx) "expected parens (for function arguments)"]
[else
"expected either = (for variable intialization) or parens (for function arguments)"])
#'id)]))))]
[_else
(raise-syntax-error #f
(format "expected a identifier after ~a" after-what)
after
#'id)])))]
[only-mode
(raise-syntax-error #f
(format "illegal in an ~a context"
(if (type-context? ctx)
"type"
"expression"))
(stx-car orig-stx))]
[(type-context? ctx)
(values (make-h-type (stx-car orig-stx) pred-def pred-id) (stx-cdr orig-stx))]
[(expression-context? ctx)
[else
(raise-syntax-error #f
"illegal in an expression context"
(format "illegal in ~a context" (context->name ctx))
(stx-car orig-stx))])))))
(define (make-proc-predicate name form)
@ -494,7 +498,7 @@
(raise-type-error '->
"non-type within a procedure-type construction"
(stx-car args-stx)))
(let-values ([(type rest-stx) (trans args-stx type-context)])
(let-values ([(type rest-stx) (trans args-stx the-type-context)])
(cons type (loop rest-stx))))))]
[result-type
(let ([trans (get-transformer result-stx)])
@ -502,7 +506,7 @@
(raise-type-error '->
"non-type in result position for procedure-type construction"
(stx-car result-stx)))
(let-values ([(type rest-stx) (trans result-stx type-context)])
(let-values ([(type rest-stx) (trans result-stx the-type-context)])
(unless (stx-null? rest-stx)
(raise-type-error '->
"extra tokens following result for procedure-type construction"
@ -523,72 +527,110 @@
(if (and (procedure? v)
(procedure-arity-includes? v n))
(values #t (lambda (arg ...)
(check-expr
(check-expr-type
#f #t result-type result-pred-id
(v (check-expr #f #f arg-type arg-pred-id arg) ...))))
(v (check-expr-type #f #f arg-type arg-pred-id arg) ...))))
(values #f #f))))))))
(define (compatible-type? val-expr val-type target-type)
(define (check-compatible-type val-expr val-type target-type fail-k)
(and (identifier? target-type)
(identifier? val-type)
(or (module-identifier=? val-type target-type)
(module-identifier=? #'val target-type)
(and (number? (syntax-e val-expr))
(module-identifier=? #'num target-type))
(and (integer? (syntax-e val-expr))
(exact? (syntax-e val-expr))
(module-identifier=? #'int target-type))
(and (real? (syntax-e val-expr))
(module-identifier=? #'real target-type))
(and (string? (syntax-e val-expr))
(module-identifier=? #'string-type target-type))))))
(define (check proc who type-name pred val)
(let-values ([(tst new-val) (pred val)])
(unless tst
(raise
(make-exn:fail:contract
(string->immutable-string
(format "~a: expected ~a value for ~a, got something else: ~e"
(or proc (if (eq? who #t) #f who) "procedure")
type-name
(cond
[(eq? who #t) "result"]
[else (if proc
(format "~a argument" who)
(if who
"initialization"
"argument"))])
val))
(current-continuation-marks))))
new-val))
(or (module-identifier=? #'obj target-type)
(and (identifier? val-type)
(module-identifier=? val-type target-type))
(let ([val-type
(if (not val-type)
(cond
[(and (integer? (syntax-e val-expr))
(exact? (syntax-e val-expr))) #'int]
[(real? (syntax-e val-expr)) #'real]
[(number? (syntax-e val-expr)) #'num]
[(string? (syntax-e val-expr)) #'string-type]
[(boolean? (syntax-e val-expr)) #'bool]
[(identifier? val-expr)
(cond
[(module-identifier=? #'false val-expr) #'bool]
[(module-identifier=? #'true val-expr) #'bool]
[else #'obj])]
[else #'obj])
val-type)])
(or (module-identifier=? val-type target-type)
(and (module-identifier=? #'num target-type)
(or (module-identifier=? val-type #'int)
(module-identifier=? val-type #'real)))
(and (module-identifier=? #'real target-type)
(or (module-identifier=? val-type #'int)))
(if (module-identifier=? val-type #'obj)
#f
(fail-k val-expr val-type target-type)))))))
(define-syntax (check-expr stx)
(define (type-mismatch val-expr val-type target-type)
(raise-syntax-error
'|type mismatch|
(format "actual type ~a does not match expected type ~a"
(syntax-object->datum val-type)
(syntax-object->datum target-type))
val-expr)))
(define (check proc who type-name pred val)
(let-values ([(tst new-val) (pred val)])
(unless tst
(raise
(make-exn:fail:contract
(string->immutable-string
(format "~a: expected ~a value for ~a, got something else: ~e"
(or proc (if (eq? who #t) #f who) "procedure")
type-name
(cond
[(eq? who #t) "result"]
[else (if proc
(format "~a argument" who)
(if who
"initialization"
"argument"))])
val))
(current-continuation-marks))))
new-val))
(define-syntax (check-expr-type stx)
(syntax-case stx ()
[(_ proc who type-name pred val)
;; Avoid the check if the static types are consistent
(let ([v (local-expand
#'val
'expression
(cons #'honu-typed
kernel-forms))])
(syntax-case v (honu-typed)
expand-stop-forms)])
(syntax-case v (honu-typed if let-values)
[(honu-typed val val-type)
(compatible-type? #'val #'val-type #'type-name)
(check-compatible-type #'val #'val-type #'type-name type-mismatch)
;; No run-time check:
#'val]
[(if t then else)
;; propagate check to body:
#'(if t
(check-expr-type proc who type-name pred then)
(check-expr-type proc who type-name pred else))]
[(let-values bindings body)
#'(let-values bindings
(check-expr-type proc who type-name pred body))]
[(honu-unparsed-block #f _ #f return-context? . body)
#'(honu-unparsed-block who type-name pred return-context? . body)]
[_else
;; Even without a type for v, we might see a literal,
;; or maybe the declaration is simply val
(if (compatible-type? v #'val #'type-name)
(if (check-compatible-type v #f #'type-name type-mismatch)
;; No run-time check:
#'val
v
;; Run-time check:
#'(check proc who 'type-name pred val))]))]))
(with-syntax ([val v])
#'(check proc who 'type-name pred val)))]))]))
(define-syntax honu-app
(syntax-rules ()
[(_ a b ...) (a b ...)]))
(define-syntax (define-typed stx)
(syntax-case stx ()
[(_ id proc-name type-name pred-id val)
[(_ id const? proc-name type-name pred-id val)
(with-syntax ([gen-id (car (generate-temporaries (list #'id)))])
#'(begin
(define gen-id val)
@ -597,47 +639,58 @@
(lambda (stx)
(syntax-case stx (set!)
[(set! id rhs)
#'(set! gen-id (check-expr set! id type-name pred-id rhs))]
(if const?
(raise-syntax-error #f "cannot assign to constant" #'id)
#'(set! gen-id (check-expr-type 'set! id type-name pred-id rhs)))]
[(id arg (... ...))
#'(#%app (honu-typed gen-id type-name) arg (... ...))]
#'(honu-app (honu-typed gen-id type-name) arg (... ...))]
[id
#'(honu-typed gen-id type-name)]))))))]))
(define-for-syntax (make-typed-procedure gen-id result-spec arg-spec)
(with-syntax ([((arg arg-type pred-id) ...) arg-spec]
[result-spec result-spec]
[gen-id gen-id])
(make-set!-transformer
(lambda (stx)
(syntax-case stx (set!)
[(set! id rhs)
(raise-syntax-error #f
"cannot assign to procedure name"
stx
#'id)]
[(id actual-arg ...)
(let ([actual-args (syntax->list #'(actual-arg ...))]
[formal-args (syntax->list #'(arg ...))])
(unless (= (length actual-args)
(length formal-args))
(raise-syntax-error
'id
(format "expects ~a arguments, provided ~a"
(length formal-args)
(length actual-args))
stx))
#'(honu-typed (#%app (honu-typed gen-id type-name)
(check-expr-type 'id 'arg arg-type pred-id actual-arg)
...)
result-spec))]
[id
#'(honu-need-type gen-id
(let ([id (lambda (arg ...)
(id arg ...))])
id)
type-name)])))))
(provide honu-typed check-expr-type) ; <-------- FIXME. These shouldn't be exported.
(define-syntax (define-typed-procedure stx)
(syntax-case stx ()
[(_ id arg-spec val)
[(_ id result-spec arg-spec val)
(with-syntax ([gen-id (car (generate-temporaries (list #'id)))])
#'(begin
(define gen-id val)
(define-syntax id
(with-syntax ([((arg arg-type pred-id) (... ...)) (quote-syntax arg-spec)])
(make-set!-transformer
(lambda (stx)
(syntax-case stx (set!)
[(set! id rhs)
(raise-syntax-error #f
"cannot assign to procedure name"
stx
#'id)]
[(id actual-arg (... ...))
(let ([actual-args (syntax->list #'(actual-arg (... ...)))]
[formal-args (syntax->list #'(arg (... ...)))])
(unless (= (length actual-args)
(length formal-args))
(raise-syntax-error
'id
(format "expects ~a arguments, provided ~a"
(length formal-args)
(length actual-args))
stx))
#'(#%app (honu-typed gen-id type-name)
(check-expr 'id 'arg arg-type pred-id actual-arg)
(... ...)))]
[id
#'(honu-typed (let ([id (lambda (arg (... ...))
(id arg (... ...)))])
id)
type-name)])))))))]))
(make-typed-procedure (quote-syntax gen-id) (quote-syntax result-spec) (quote-syntax arg-spec)))))]))
(define-syntax honu-typed
(syntax-rules ()
@ -659,7 +712,7 @@
(let ([expr (local-expand
expr
(generate-expand-context)
kernel-forms)])
expand-stop-forms)])
(syntax-case expr (begin)
[(begin . rest)
(loop (syntax->list #'rest))]
@ -675,15 +728,15 @@
proc-id
(syntax-e proc-id))
(reverse (cons
#`(check-expr '#,proc-id #t
#,result-type-name
#,result-pred-id
#,(car prev-exprs))
#`(check-expr-type '#,proc-id #t
#,result-type-name
#,result-pred-id
#,(car prev-exprs))
(cdr prev-exprs)))
(begin
(unless (or (not proc-id)
(not (syntax-e proc-id))
(module-identifier=? #'type-name #'void-type))
(module-identifier=? #'type-name #'obj))
(error "no expression for type check; should have been "
"caught earlier"))
(reverse prev-exprs)))
@ -710,8 +763,8 @@
#`(honu-block proc-id result-type-name result-pred-id #,@(parse-block
#'body
(if (syntax-e #'return-context?)
return-block-context
block-context)))]))
the-return-block-context
the-block-context)))]))
(define-syntax (honu-unparsed-expr stx)
(syntax-case stx ()
@ -723,7 +776,7 @@
(define-syntax (#%parens stx)
(syntax-case stx ()
[(_ rator (rand ...)) (syntax/loc #'rator (rator rand ...))]))
[(_ rator (rand ...)) (syntax/loc #'rator (honu-app rator rand ...))]))
;; --------------------------------------------------------
;; Defining a new transformer or new type
@ -744,13 +797,13 @@
(define pred-id (let ([pred pred-expr])
(lambda (v)
(values (pred v) v))))
(define-syntax id (make-honu-type #'pred-id #f #f))))]))
(define-syntax id (make-honu-type #'pred-id #f))))]))
(define-syntax (define-type-constructor stx)
(syntax-case stx ()
[(_ id generator-expr)
(identifier? #'id)
#'(define-syntax id (make-honu-type #f generator-expr #f))]))
#'(define-syntax id (make-honu-type #f generator-expr))]))
;; ----------------------------------------
;; Pre-defined types and forms
@ -759,13 +812,44 @@
(and (integer? v) (exact? v)))
(define-type int exact-integer?)
(define-type bool boolean?)
(define-type real real?)
(define-type num number?)
(define-type obj (lambda (x) #t))
(define-type string-type string?)
(define-syntax function (make-honu-type #'(lambda (x) (values #t x)) #f 'function))
(define-syntax var (make-honu-type #'(lambda (x) (values #t x)) #f 'var))
(define-for-syntax (make-definition-form what this-context this-context?)
(make-honu-transformer
(lambda (orig-stx ctx)
(when (this-context? ctx)
(raise-syntax-error #f
(format "redundant in ~a context" (context->name ctx))
(stx-car orig-stx)))
(unless (block-context? ctx)
(raise-syntax-error #f
(format "illegal in ~a context" (context->name ctx))
(stx-car orig-stx)))
(let ([body (stx-cdr orig-stx)])
(cond
[(stx-null? body)
(raise-syntax-error #f
(format "expected a ~a definition after keyword" what)
(stx-car orig-stx))]
[(get-transformer body)
=> (lambda (transformer)
(transformer body this-context))]
[else
(let ([id (stx-car orig-stx)])
(unless (honu-identifier? id)
(raise-syntax-error #f
(format "expected an identifier for a ~a definition" what)
(stx-car orig-stx)
id))
((make-honu-type #'(lambda (x) (values #t x)) #f) orig-stx this-context))])))))
(define-syntax function (make-definition-form 'function the-function-definition-context function-definition-context?))
(define-syntax var (make-definition-form 'variable the-variable-definition-context variable-definition-context?))
(define-syntax const (make-definition-form 'variable the-constant-definition-context constant-definition-context?))
(define-type-constructor -> make-proc-predicate)
@ -781,7 +865,6 @@
[(other rest) (loop #'rest null (stx-car body))])
(values (combine one other) rest))]
[(\; . rest)
(identifier? #'id)
(values (parse-one (reverse accum) prev-comma (stx-car body)) #'rest)]
[(x . rest)
(loop #'rest (cons #'x accum) #f)]))])))
@ -796,7 +879,7 @@
(lambda (stxes prev-comma-stx term-stx)
(syntax-case stxes ()
[(id)
(identifier? #'id)
(honu-identifier? #'id)
#`(provide id)]
[else
(raise-syntax-error
@ -890,7 +973,7 @@
(car stxes)
(stx-car body))]
[(fn)
(identifier? #'fn)
(honu-identifier? #'fn)
#'fn]
[else
(raise-syntax-error
@ -902,13 +985,13 @@
(syntax-case stxes (rename #%parens \,)
[(rename (#%parens spec0 spec ... \, local-id \, remote-id) . rest)
(begin
(unless (identifier? #'local-id)
(unless (honu-identifier? #'local-id)
(raise-syntax-error
#f
"expected an identifier"
(stx-car stxes)
#'local-id))
(unless (identifier? #'remote-id)
(unless (honu-identifier? #'remote-id)
(raise-syntax-error
#f
"expected an identifier"
@ -935,8 +1018,8 @@
(lambda (stx ctx)
(unless (return-block-context? ctx)
(raise-syntax-error #f "allowed only in a tail position" (stx-car stx)))
(let-values ([(val-stxs after-expr) (extract-until (stx-cdr stx)
(list #'\;))])
(let-values ([(val-stxs after-expr terminator) (extract-until (stx-cdr stx)
(list #'\;))])
(unless val-stxs
(raise-syntax-error
#f
@ -962,12 +1045,10 @@
(lambda (stx ctx)
(define (get-block-or-statement kw rest)
(syntax-case rest (#%braces)
[((#%braces then ...) . rest)
(values #`(honu-unparsed-block #f void-type #f #,(return-block-context? ctx) then ...)
#'rest)]
[((#%braces then ...) . rrest)
(values (stx-cdr (stx-car rest)) #'rrest)]
[else
(let-values ([(val-stxs rest) (extract-until rest
(list #'\;))])
(let-values ([(val-stxs rest terminator) (extract-until rest (list #'\;) #t)])
(unless val-stxs
(raise-syntax-error
#f
@ -979,34 +1060,82 @@
"expected an expression before semicolon"
kw
(stx-car rest)))
(if (return-block-context? ctx)
(values (parse-tail-expr val-stxs) (stx-cdr rest))
(values (parse-expr val-stxs) (stx-cdr rest))))]))
(values val-stxs (stx-cdr rest)))]))
(define (wrap-block exprs rest)
#`(honu-unparsed-block #f obj #f #,(and (return-block-context? ctx)
(stx-null? rest))
. #,exprs))
(syntax-case stx (#%parens)
[(_ (#%parens test ...) . rest)
(let ([test-expr (parse-expr (syntax->list #'(test ...)))])
(let-values ([(then-expr rest) (get-block-or-statement (stx-car stx) #'rest)])
(syntax-case rest (else)
[(else . rest2)
(let-values ([(else-expr rest) (get-block-or-statement (stx-car rest) #'rest2)])
(values #`(if #,test-expr #,then-expr #,else-expr)
rest))]
[_else
(values #`(if #,test-expr #,then-expr) rest)])))]
(let* ([tests #'(test ...)])
(when (stx-null? tests)
(raise-syntax-error
#f
"missing test expression"
(stx-car stx)
(stx-car (stx-cdr stx))))
(let ([test-expr (parse-expr (syntax->list tests))])
(let-values ([(then-exprs rest) (get-block-or-statement (stx-car stx) #'rest)])
(syntax-case rest (else)
[(else . rest2)
(let-values ([(else-exprs rest) (get-block-or-statement (stx-car rest) #'rest2)])
(values #`(if #,test-expr
#,(wrap-block then-exprs rest)
#,(wrap-block else-exprs rest))
rest))]
[_else
(values #`(if #,test-expr #,(wrap-block then-exprs rest) (void)) rest)]))))]
[_else
(raise-syntax-error
#f
"expected a parenthesized test after `if' keyword"
(stx-car stx))])))
;; ----------------------------------------
;; Class form
(define-honu-syntax honu-class
(lambda (stx ctx)
(syntax-case stx (#%braces)
[(form id . rest)
(not (honu-identifier? #'id))
(raise-syntax-error
#f
"expected an identifier for the class"
#'form
#'id)]
[(form id (#%braces content ...) . rest)
(let ([id #'id])
10)]
[(form)
(raise-syntax-error
#f
"missing name for the class"
#'form)]
[(form id next . _)
(raise-syntax-error
#f
"expected braces after class name, found something else"
#'form
#'next)]
[(form id)
(raise-syntax-error
#f
"missing braces after class name"
#'form
#'id)])))
;; ----------------------------------------
;; Main compiler loop
(define-syntax (honu-unparsed-begin stx)
(syntax-case stx ()
[(_) #'(begin)]
[(_ . body) (let-values ([(code rest) (parse-block-one top-block-context
[(_ . body) (let-values ([(code rest) (parse-block-one the-top-block-context
#'body
values
(lambda ()
@ -1024,13 +1153,14 @@
(define true #t)
(define false #f)
(provide int real obj
function var
(provide int real bool obj
function var const
(rename string-type string) ->
\;
(rename set! =)
(rename honu-return return)
(rename honu-if if)
(rename honu-class class)
+ - * / (rename modulo %)
(rename string->number stringToNumber)
(rename number->string numberToString)

60
collects/honu-module/private/contexts.ss Normal file
View File

@ -0,0 +1,60 @@
(module contexts mzscheme
(define-struct block-context ())
(define-struct (top-block-context block-context) ())
(define-struct (return-block-context block-context) ())
(define-struct definition-context ())
(define-struct (function-definition-context definition-context) ())
(define-struct (value-definition-context definition-context) ())
(define-struct (constant-definition-context value-definition-context) ())
(define-struct (variable-definition-context value-definition-context) ())
(define-struct expression-context ())
(define-struct type-context ())
(define the-block-context (make-block-context))
(define the-top-block-context (make-top-block-context))
(define the-return-block-context (make-return-block-context))
(define the-function-definition-context (make-function-definition-context))
(define the-variable-definition-context (make-variable-definition-context))
(define the-constant-definition-context (make-constant-definition-context))
(define the-expression-context (make-expression-context))
(define the-type-context (make-type-context))
(define (context->name ctx)
(cond
[(type-context? ctx) "a type"]
[(block-context? ctx) "a block"]
[(variable-definition-context? ctx) "a variable-definition"]
[(constant-definition-context? ctx) "a constant-definition"]
[(function-definition-context? ctx) "a function-definition"]
[else "an expression"]))
(provide block-context?
top-block-context?
return-block-context?
definition-context?
function-definition-context?
value-definition-context?
variable-definition-context?
constant-definition-context?
expression-context?
type-context?
the-block-context
the-top-block-context
the-return-block-context
the-function-definition-context
the-variable-definition-context
the-constant-definition-context
the-expression-context
the-type-context
context->name))

32
collects/honu-module/private/util.ss
View File

@ -4,16 +4,24 @@
(require (lib "stx.ss" "syntax"))
(define (extract-until r ids)
(let loop ([r r][val-stxs null])
(cond
[(stx-null? r)
(values #f #f)]
[(and (identifier? (stx-car r))
(ormap (lambda (id)
(module-identifier=? id (stx-car r)))
ids))
(values (reverse val-stxs) r)]
[else
(loop (stx-cdr r) (cons (stx-car r) val-stxs))]))))
(define extract-until
(case-lambda
[(r ids keep?)
(let loop ([r r][val-stxs null])
(cond
[(stx-null? r)
(values #f #f #f)]
[(and (identifier? (stx-car r))
(ormap (lambda (id)
(module-identifier=? id (stx-car r)))
ids))
(values (reverse (if keep?
(cons (stx-car r) val-stxs)
val-stxs))
r
(stx-car r))]
[else
(loop (stx-cdr r) (cons (stx-car r) val-stxs))]))]
[(r ids) (extract-until r ids #f)])))

27
collects/planet/resolver.ss
View File

@ -169,14 +169,16 @@ an appropriate subdirectory.
(define install? (make-parameter #t)) ;; if #f, will not install packages and instead give an error
(define (resolver spec module-path stx)
;; ensure these directories exist
(make-directory* (PLANET-DIR))
(make-directory* (CACHE-DIR))
(establish-diamond-property-monitor)
(cond
[(or spec stx) (planet-resolve spec module-path stx)]
[else module-path]))
(define resolver
(case-lambda
[(name) (void)]
[(spec module-path stx load?)
;; ensure these directories exist
(make-directory* (PLANET-DIR))
(make-directory* (CACHE-DIR))
(establish-diamond-property-monitor)
(planet-resolve spec module-path stx load?)]
[(spec module-path stx) (resolver spec module-path stx #t)]))
; ==========================================================================================
; DIAMOND PROPERTY STUFF
@ -270,10 +272,10 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
; planet-resolve : PLANET-REQUEST symbol syntax[PLANET-REQUEST] -> symbol
; resolves the given request. Returns a name corresponding to the module in the correct
; environment
(define (planet-resolve spec module-path stx)
(define (planet-resolve spec module-path stx load?)
(let-values ([(path pkg) (get-planet-module-path/pkg spec module-path stx)])
(add-pkg-to-diamond-registry! pkg)
(do-require path (pkg-path pkg) module-path stx)))
(do-require path (pkg-path pkg) module-path stx load?)))
;; get-planet-module-path/pkg :PLANET-REQUEST symbol syntax[PLANET-REQUEST] -> path PKG
;; returns the matching package and the file path to the specific request
@ -559,12 +561,13 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
; do-require : path path symbol syntax -> symbol
; requires the given filename, which must be a module, in the given path.
(define (do-require file-path package-path module-path stx)
(define (do-require file-path package-path module-path stx load?)
(parameterize ((current-load-relative-directory package-path))
((current-module-name-resolver)
file-path
module-path
stx)))
stx
load?)))
; ============================================================
; UTILITY

14
collects/tests/mred/item.ss
View File

@ -1269,7 +1269,7 @@
(define rb1 (make-object radio-box% "&Left" rb1-l hp callback))
(define rb2-l (list "First" "Last"))
(define rb2 (make-object radio-box% "&Center" rb2-l hp callback))
(define rb3-l (list "Top" "Middle" "Bottom"))
(define rb3-l (list "&Top" "&Middle" "&Bottom"))
(define rb3 (make-object radio-box% "&Right" rb3-l hp callback))
(define rbs (list rb1 rb2 rb3))
@ -1285,8 +1285,8 @@
(with-handlers ([exn? void])
(f rb p)
(error "no exn raisd")))))
(define type-err (mk-err exn:application:type?))
(define mismatch-err (mk-err exn:application:mismatch?))
(define type-err (mk-err exn:fail:contract?))
(define mismatch-err (mk-err exn:fail:contract?))
(define do-sel (lambda (sel n) (for-each (lambda (rb) (sel rb (n rb))) rbs)))
(define sel-minus (lambda (sel) (do-sel (type-err sel) (lambda (rb) -1))))
@ -1472,7 +1472,7 @@
(make-object button%
(string-append "Select Bad -1" mname) p2
(lambda (b e)
(with-handlers ([exn:application:type? void])
(with-handlers ([exn:fail:contract? void])
(method -1)
(error "expected a type exception")))))
(make-object button%
@ -1490,7 +1490,7 @@
(make-object button%
(string-append "Select Bad X" mname) p2
(lambda (b e)
(with-handlers ([exn:application:mismatch? void])
(with-handlers ([exn:fail:contract? void])
(method (if numerical?
(send c get-number)
#f))
@ -1537,8 +1537,8 @@
(with-handlers ([exn? void])
(send c get-string i)
(error "out-of-bounds: no exn")))])
(bad exn:application:type? -1)
(bad exn:application:mismatch? (send c get-number)))
(bad exn:fail:contract? -1)
(bad exn:fail:contract? (send c get-number)))
(unless (not (send c find-string "nada"))
(error "find-string of nada wasn't #f"))
(for-each

8
collects/tests/mzscheme/number.ss
View File

@ -684,6 +684,8 @@
(test 0.25-0.0i / 1 4+0.0i)
(test 0.25+0.0i / 1+0.0i 4+0.0i)
(test 0 / 0 4+3i)
(test 0.25+0.0i / 1e300+1e300i (* 4 1e300+1e300i))
(test 0.25+0.0i / 1e-300+1e-300i (* 4 1e-300+1e-300i))
(test 3 / 1 1/3)
(test -3 / 1 -1/3)
@ -1333,6 +1335,10 @@
(test 3/4 magnitude -3/4)
(test 10.0 magnitude 10.0+0.0i)
(test 10.0 magnitude -10.0+0.0i)
(test 10.0 magnitude 0+10.0i)
(test 10 magnitude 0+10i)
(test 141421.0 round (* 1e-295 (magnitude 1e300+1e300i)))
(test 141421.0 round (* 1e+305 (magnitude 1e-300+1e-300i)))
(test 0 angle 1)
(test 0 angle 1.0)
@ -1622,7 +1628,7 @@
; Should at least be close...
(test 4.0 round (log (exp 4.0)))
(test 125.0 round (* 1000 (asin (sin 0.125))))
(test 125.0d0 round (* 1000 (asin (sin 0.125+0.0d0i))))
(test 125.0d0 round (* 1000 (magnitude (asin (sin 0.125+0.0d0i)))))
(test 125.0 round (* 1000 (asin (sin 1/8))))
(test 125.0 round (* 1000 (acos (cos 0.125))))
(test 125.0d0 round (* 1000 (acos (cos 0.125+0.0d0i))))

51
collects/tests/mzscheme/stx.ss
View File

@ -1069,6 +1069,57 @@
(require @!$m)
(test '(10 20 #t) '@!$get @!$get)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Test lazy unmarshaling of renamings and module-name resolution
(let ([load-ok? #t])
(parameterize ([current-namespace (make-namespace)]
[current-module-name-resolver
(case-lambda
[(a) (void)]
[(name _ __) 'huh?]
[(name _ __ load?)
(unless load-ok?
(test #f 'load-ok load?))
'a])])
(let ([a-code '(module a mzscheme
(provide x y)
(define x 1)
(define y #'x))])
(eval a-code)
(let ([b-code (let ([p (open-output-bytes)])
(write (compile
'(module b mzscheme
(require "a")
(provide f)
(define (f) #'x)))
p)
(lambda ()
(parameterize ([read-accept-compiled #t])
(read (open-input-bytes (get-output-bytes p))))))]
[x-id (parameterize ([current-namespace (make-namespace)])
(eval a-code)
(eval '(require a))
(eval '#'x))])
(eval (b-code))
(eval '(require b))
(set! load-ok? #f)
(test #f eval '(module-identifier=? (f) #'x))
(test #t eval `(module-identifier=? (f) (quote-syntax ,x-id)))
(eval '(require a))
(test #t eval '(module-identifier=? (f) #'x))
(test #t eval `(module-identifier=? (f) (quote-syntax ,x-id)))
(parameterize ([current-namespace (make-namespace)])
(eval '(module a mzscheme
(provide y)
(define y 3)))
(set! load-ok? #t)
(eval (b-code))
(eval '(require b))
(set! load-ok? #f)
(test #t eval '(module-identifier=? (f) #'x))
(test #f eval `(module-identifier=? (f) (quote-syntax ,x-id))))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)

3
collects/tests/mzscheme/syntax.ss
View File

@ -229,6 +229,9 @@
(syntax-test #'(set! x . 1))
(syntax-test #'(set! x 1 . 2))
(define (set!-not-ever-defined) (set! not-ever-defined (add1 not-ever-defined)))
(err/rt-test (set!-not-ever-defined) exn:fail:contract:variable?)
(set!-values (x) 9)
(test 9 'set!-values x)
(test (void) 'set!-values (set!-values () (values)))

35
collects/tests/mzscheme/thread.ss
View File

@ -1184,6 +1184,41 @@
(current-preserved-thread-cell-values post)
(test 3 thread-cell-ref c3)))))))
;; ----------------------------------------
;; Check that nested continuations sharing saved runstacks
;; work properly:
(test '(5050 5050)
'shared-saved-runstacks
(parameterize ([current-thread-initial-stack-size 3])
(let ([ch (make-channel)]
[r-ch (make-channel)])
(let ([t (thread
(lambda ()
(define (mk-list put)
(let loop ([n 100])
(if (zero? n)
(let/cc k
(put k)
null)
(cons n (loop (sub1 n))))))
(define (sum l)
(let loop ([l l])
(if (null? l)
0
(+ (car l) (loop (cdr l))))))
(let ([c1 #f])
(let ([l (mk-list (lambda (k)
(sum (mk-list (lambda (k) (channel-put ch k))))))])
(channel-put r-ch (sum l))))))])
(let ([k (channel-get ch)])
(list
(sync r-ch)
(begin
(thread (lambda () (k null)))
(sync r-ch))))))))
; --------------------
(report-errs)

13
doc/release-notes/mzscheme/HISTORY
View File

@ -1,3 +1,16 @@
Version 350.2
Changed the module name resolver protocol so that the resolver is
required to accept 1, 3, and 4 arguments; the new 4-argument mode
supports resolving a module path without loading the module
Changed namespace-attach-module and namespace-unprotect-module
to accept quoted module paths, instead of only symbolic names
Fixed avoidable overflow and undeflow in magnitude and / for
inexact complex numbers
Version 350.1
Added define-member-name, member-name-key, and generate-member-key
to class.ss
Version 350, June 2006
JIT compiler:
Added just-in-time native-code compiler with a new eval-jit-enabled

3
src/mzscheme/include/mzscheme.exp
View File

@ -254,7 +254,7 @@ scheme_utf8_decode_all
scheme_utf8_decode_prefix
scheme_utf8_decode_to_buffer
scheme_utf8_decode_to_buffer_len
scheme_utf8_decode_count
MZ_EXTERN
scheme_utf8_encode
scheme_utf8_encode_all
scheme_utf8_encode_to_buffer
@ -426,7 +426,6 @@ scheme_primitive_module
scheme_finish_primitive_module
scheme_protect_primitive_provide
scheme_make_modidx
scheme_declare_module
scheme_apply_for_syntax_in_env
scheme_dynamic_require
scheme_intern_symbol

3
src/mzscheme/include/mzscheme3m.exp
View File

@ -261,7 +261,7 @@ scheme_utf8_decode_all
scheme_utf8_decode_prefix
scheme_utf8_decode_to_buffer
scheme_utf8_decode_to_buffer_len
scheme_utf8_decode_count
MZ_EXTERN
scheme_utf8_encode
scheme_utf8_encode_all
scheme_utf8_encode_to_buffer
@ -433,7 +433,6 @@ scheme_primitive_module
scheme_finish_primitive_module
scheme_protect_primitive_provide
scheme_make_modidx
scheme_declare_module
scheme_apply_for_syntax_in_env
scheme_dynamic_require
scheme_intern_symbol

2
src/mzscheme/include/mzwin.def
View File

@ -246,7 +246,6 @@ EXPORTS
scheme_utf8_decode_prefix
scheme_utf8_decode_to_buffer
scheme_utf8_decode_to_buffer_len
scheme_utf8_decode_count
scheme_utf8_encode
scheme_utf8_encode_all
scheme_utf8_encode_to_buffer
@ -418,7 +417,6 @@ EXPORTS
scheme_finish_primitive_module
scheme_protect_primitive_provide
scheme_make_modidx
scheme_declare_module
scheme_apply_for_syntax_in_env
scheme_dynamic_require
scheme_intern_symbol

6
src/mzscheme/include/scheme.h
View File

@ -110,6 +110,12 @@ typedef long FILE;
# define MZ_SIGSET(s, f) sigset(s, f)
#endif
#ifdef MZ_XFORM
# define XFORM_NONGCING __xform_nongcing__
#else
# define XFORM_NONGCING /* empty */
#endif
#ifdef MZ_XFORM
START_XFORM_SUSPEND;
#endif

2
src/mzscheme/src/bignum.c
View File

@ -590,7 +590,7 @@ static bigdig* allocate_bigdig_array(int length)
}
/* We don't want to count leading digits of 0 in the bignum's length */
static int bigdig_length(bigdig* array, int alloced)
XFORM_NONGCING static int bigdig_length(bigdig* array, int alloced)
{
alloced--;
while (alloced >= 0 && array[alloced] == 0) {

77
src/mzscheme/src/complex.c
View File

@ -209,35 +209,76 @@ Scheme_Object *scheme_complex_multiply(const Scheme_Object *a, const Scheme_Obje
}
Scheme_Object *scheme_complex_divide(const Scheme_Object *n, const Scheme_Object *d)
Scheme_Object *scheme_complex_divide(const Scheme_Object *_n, const Scheme_Object *_d)
{
Scheme_Complex *cn = (Scheme_Complex *)n;
Scheme_Complex *cd = (Scheme_Complex *)d;
Scheme_Object *a_sq_p_b_sq, *r, *i;
Scheme_Complex *cn = (Scheme_Complex *)_n;
Scheme_Complex *cd = (Scheme_Complex *)_d;
Scheme_Object *den, *r, *i, *a, *b, *c, *d, *cm, *dm, *aa[1];
if ((cn->r == zero) && (cn->i == zero))
return zero;
a = cn->r;
b = cn->i;
c = cd->r;
d = cd->i;
/* Check for exact-zero simplifications in d: */
if (cd->r == zero) {
i = scheme_bin_minus(zero, scheme_bin_div(cn->r, cd->i));
r = scheme_bin_div(cn->i, cd->i);
if (c == zero) {
i = scheme_bin_minus(zero, scheme_bin_div(a, d));
r = scheme_bin_div(b, d);
return scheme_make_complex(r, i);
} else if (cd->i == zero) {
r = scheme_bin_div(cn->r, cd->r);
i = scheme_bin_div(cn->i, cd->r);
} else if (d == zero) {
r = scheme_bin_div(a, c);
i = scheme_bin_div(b, c);
return scheme_make_complex(r, i);
}
a_sq_p_b_sq = scheme_bin_plus(scheme_bin_mult(cd->r, cd->r),
scheme_bin_mult(cd->i, cd->i));
aa[0] = d;
if (SCHEME_TRUEP(scheme_zero_p(1, aa))) {
/* This is like dividing by a real number, except that
the inexact 0 imaginary part can interact with +inf.0 and +nan.0 */
r = scheme_bin_plus(scheme_bin_div(a, c),
/* Either 0.0 or +nan.0: */
scheme_bin_mult(d, b));
i = scheme_bin_minus(scheme_bin_div(b, c),
/* Either 0.0 or +nan.0: */
scheme_bin_mult(d, a));
return scheme_make_complex(r, i);
}
aa[0] = c;
if (SCHEME_TRUEP(scheme_zero_p(1, aa))) {
r = scheme_bin_plus(scheme_bin_div(b, d),
/* Either 0.0 or +nan.0: */
scheme_bin_mult(c, a));
i = scheme_bin_minus(scheme_bin_mult(c, b), /* either 0.0 or +nan.0 */
scheme_bin_div(a, d));
return scheme_make_complex(r, i);
}
aa[0] = c;
cm = scheme_abs(1, aa);
aa[0] = d;
dm = scheme_abs(1, aa);
if (scheme_bin_lt(cm, dm)) {
cm = a;
a = b;
b = cm;
cm = c;
c = d;
d = cm;
}
r = scheme_bin_div(c, d);
den = scheme_bin_plus(d, scheme_bin_mult(c, r));
r = scheme_bin_div(scheme_bin_plus(scheme_bin_mult(cd->r, cn->r),
scheme_bin_mult(cd->i, cn->i)),
a_sq_p_b_sq);
i = scheme_bin_div(scheme_bin_minus(scheme_bin_mult(cd->r, cn->i),
scheme_bin_mult(cd->i, cn->r)),
a_sq_p_b_sq);
i = scheme_bin_div(scheme_bin_minus(a, scheme_bin_mult(b, r)),
den);
r = scheme_bin_div(scheme_bin_plus(b, scheme_bin_mult(a, r)),
den);
return scheme_make_complex(r, i);
}

4469
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

13
src/mzscheme/src/env.c
View File

@ -644,7 +644,7 @@ Scheme_Env *scheme_make_empty_env(void)
static Scheme_Env *make_env(Scheme_Env *base, int semi, int toplevel_size)
{
Scheme_Bucket_Table *toplevel, *syntax;
Scheme_Hash_Table *module_registry;
Scheme_Hash_Table *module_registry, *export_registry;
Scheme_Object *modchain;
Scheme_Env *env;
@ -655,14 +655,17 @@ static Scheme_Env *make_env(Scheme_Env *base, int semi, int toplevel_size)
syntax = NULL;
modchain = NULL;
module_registry = NULL;
export_registry = NULL;
} else {
syntax = scheme_make_bucket_table(7, SCHEME_hash_ptr);
if (base) {
modchain = base->modchain;
module_registry = base->module_registry;
export_registry = base->export_registry;
} else {
if (semi < 0) {
module_registry = NULL;
export_registry = NULL;
modchain = NULL;
} else {
Scheme_Hash_Table *modules;
@ -673,6 +676,8 @@ static Scheme_Env *make_env(Scheme_Env *base, int semi, int toplevel_size)
module_registry = scheme_make_hash_table(SCHEME_hash_ptr);
module_registry->iso.so.type = scheme_module_registry_type;
export_registry = scheme_make_hash_table(SCHEME_hash_ptr);
}
}
}
@ -686,6 +691,7 @@ static Scheme_Env *make_env(Scheme_Env *base, int semi, int toplevel_size)
env->syntax = syntax;
env->modchain = modchain;
env->module_registry = module_registry;
env->export_registry = export_registry;
}
return env;
@ -725,6 +731,7 @@ void scheme_prepare_exp_env(Scheme_Env *env)
eenv->module = env->module;
eenv->module_registry = env->module_registry;
eenv->export_registry = env->export_registry;
eenv->insp = env->insp;
modchain = SCHEME_VEC_ELS(env->modchain)[1];
@ -759,6 +766,7 @@ void scheme_prepare_template_env(Scheme_Env *env)
eenv->module = env->module;
eenv->module_registry = env->module_registry;
eenv->export_registry = env->export_registry;
eenv->insp = env->insp;
modchain = SCHEME_VEC_ELS(env->modchain)[2];
@ -789,6 +797,7 @@ Scheme_Env *scheme_clone_module_env(Scheme_Env *menv, Scheme_Env *ns, Scheme_Obj
menv2->module = menv->module;
menv2->module_registry = ns->module_registry;
menv2->export_registry = ns->export_registry;
menv2->insp = menv->insp;
menv2->syntax = menv->syntax;
@ -2322,7 +2331,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
if (modidx) {
/* If it's an access path, resolve it: */
modname = scheme_module_resolve(modidx);
modname = scheme_module_resolve(modidx, 1);
if (env->genv->module && SAME_OBJ(modname, env->genv->module->modname)) {
modidx = NULL;

14
src/mzscheme/src/eval.c
View File

@ -1332,7 +1332,7 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx,
Scheme_Env *menv;
/* If it's a name id, resolve the name. */
modname = scheme_module_resolve(modidx);
modname = scheme_module_resolve(modidx, 1);
if (env->module && SAME_OBJ(env->module->modname, modname)
&& (env->mod_phase == mod_phase))
@ -3041,8 +3041,9 @@ static void *compile_k(void)
form = add_renames_unless_module(form, genv);
if (genv->module) {
form = scheme_stx_phase_shift(form, 0,
genv->module->src_modidx,
genv->module->self_modidx);
genv->module->me->src_modidx,
genv->module->self_modidx,
genv->export_registry);
}
}
@ -3877,7 +3878,7 @@ static Scheme_Object *check_top(const char *when, Scheme_Object *form, Scheme_Co
if (modidx) {
/* If it's an access path, resolve it: */
if (env->genv->module
&& SAME_OBJ(scheme_module_resolve(modidx), env->genv->module->modname))
&& SAME_OBJ(scheme_module_resolve(modidx, 1), env->genv->module->modname))
bad = 0;
else
bad = 1;
@ -6041,7 +6042,7 @@ Scheme_Object *scheme_eval_compiled_stx_string(Scheme_Object *expr, Scheme_Env *
result = scheme_make_vector(len - 1, NULL);
for (i = 0; i < len - 1; i++) {
s = scheme_stx_phase_shift(SCHEME_VEC_ELS(expr)[i], shift, orig, modidx);
s = scheme_stx_phase_shift(SCHEME_VEC_ELS(expr)[i], shift, orig, modidx, env->export_registry);
SCHEME_VEC_ELS(result)[i] = s;
}
@ -6765,7 +6766,8 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp,
if (rp->num_stxes) {
i = rp->num_toplevels;
v = scheme_stx_phase_shift_as_rename(now_phase - src_phase, src_modidx, now_modidx);
v = scheme_stx_phase_shift_as_rename(now_phase - src_phase, src_modidx, now_modidx,
genv ? genv->export_registry : NULL);
if (v) {
/* Put lazy-shift info in a[i]: */
v = scheme_make_raw_pair(v, (Scheme_Object *)rp->stxes);

8
src/mzscheme/src/fun.c
View File

@ -3107,7 +3107,7 @@ static Scheme_Saved_Stack *copy_out_runstack(Scheme_Thread *p,
Scheme_Object **runstack_start,
Scheme_Cont *share_from)
{
Scheme_Saved_Stack *saved, *isaved, *csaved, *share_saved, *ss;
Scheme_Saved_Stack *saved, *isaved, *csaved, *share_saved, *share_csaved, *ss;
Scheme_Object **start;
long size;
@ -3136,12 +3136,14 @@ static Scheme_Saved_Stack *copy_out_runstack(Scheme_Thread *p,
/* Copy saved runstacks: */
isaved = saved;
share_saved = NULL;
share_csaved = NULL;
if (share_from) {
/* We can share all saved runstacks */
share_saved = share_from->ss.runstack_saved;
share_csaved = share_from->ss.runstack_saved;
share_saved = share_from->runstack_copied->prev;
}
for (csaved = p->runstack_saved; csaved; csaved = csaved->prev) {
if (share_saved && (csaved->runstack_start == share_saved->runstack_start)) {
if (share_csaved && (csaved->runstack_start == share_csaved->runstack_start)) {
/* Share */
isaved->prev = share_saved;
break;

637
src/mzscheme/src/module.c
View File

File diff suppressed because it is too large Load Diff

57
src/mzscheme/src/mzmark.c
View File

@ -1838,6 +1838,7 @@ static int namespace_val_MARK(void *p) {
gcMARK(e->module);
gcMARK(e->module_registry);
gcMARK(e->export_registry);
gcMARK(e->insp);
gcMARK(e->rename);
@ -1871,6 +1872,7 @@ static int namespace_val_FIXUP(void *p) {
gcFIXUP(e->module);
gcFIXUP(e->module_registry);
gcFIXUP(e->export_registry);
gcFIXUP(e->insp);
gcFIXUP(e->rename);
@ -2104,15 +2106,10 @@ static int module_val_MARK(void *p) {
gcMARK(m->body);
gcMARK(m->et_body);
gcMARK(m->provides);
gcMARK(m->provide_srcs);
gcMARK(m->provide_src_names);
gcMARK(m->me);
gcMARK(m->provide_protects);
gcMARK(m->kernel_exclusion);
gcMARK(m->indirect_provides);
gcMARK(m->src_modidx);
gcMARK(m->self_modidx);
gcMARK(m->accessible);
@ -2144,15 +2141,10 @@ static int module_val_FIXUP(void *p) {
gcFIXUP(m->body);
gcFIXUP(m->et_body);
gcFIXUP(m->provides);
gcFIXUP(m->provide_srcs);
gcFIXUP(m->provide_src_names);
gcFIXUP(m->me);
gcFIXUP(m->provide_protects);
gcFIXUP(m->kernel_exclusion);
gcFIXUP(m->indirect_provides);
gcFIXUP(m->src_modidx);
gcFIXUP(m->self_modidx);
gcFIXUP(m->accessible);
@ -2177,6 +2169,43 @@ static int module_val_FIXUP(void *p) {
#define module_val_IS_CONST_SIZE 1
static int module_exports_val_SIZE(void *p) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Module_Exports));
}
static int module_exports_val_MARK(void *p) {
Scheme_Module_Exports *m = (Scheme_Module_Exports *)p;
gcMARK(m->provides);
gcMARK(m->provide_srcs);
gcMARK(m->provide_src_names);
gcMARK(m->kernel_exclusion);
gcMARK(m->src_modidx);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Module_Exports));
}
static int module_exports_val_FIXUP(void *p) {
Scheme_Module_Exports *m = (Scheme_Module_Exports *)p;
gcFIXUP(m->provides);
gcFIXUP(m->provide_srcs);
gcFIXUP(m->provide_src_names);
gcFIXUP(m->kernel_exclusion);
gcFIXUP(m->src_modidx);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Module_Exports));
}
#define module_exports_val_IS_ATOMIC 0
#define module_exports_val_IS_CONST_SIZE 1
static int modidx_val_SIZE(void *p) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Modidx));

25
src/mzscheme/src/mzmarksrc.c
View File

@ -715,6 +715,7 @@ namespace_val {
gcMARK(e->module);
gcMARK(e->module_registry);
gcMARK(e->export_registry);
gcMARK(e->insp);
gcMARK(e->rename);
@ -823,15 +824,10 @@ module_val {
gcMARK(m->body);
gcMARK(m->et_body);
gcMARK(m->provides);
gcMARK(m->provide_srcs);
gcMARK(m->provide_src_names);
gcMARK(m->me);
gcMARK(m->provide_protects);
gcMARK(m->kernel_exclusion);
gcMARK(m->indirect_provides);
gcMARK(m->src_modidx);
gcMARK(m->self_modidx);
gcMARK(m->accessible);
@ -852,6 +848,21 @@ module_val {
gcBYTES_TO_WORDS(sizeof(Scheme_Module));
}
module_exports_val {
mark:
Scheme_Module_Exports *m = (Scheme_Module_Exports *)p;
gcMARK(m->provides);
gcMARK(m->provide_srcs);
gcMARK(m->provide_src_names);
gcMARK(m->kernel_exclusion);
gcMARK(m->src_modidx);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Module_Exports));
}
modidx_val {
mark:
Scheme_Modidx *modidx = (Scheme_Modidx *)p;

29
src/mzscheme/src/number.c
View File

@ -2123,12 +2123,31 @@ static Scheme_Object *magnitude(int argc, Scheme_Object *argv[])
if (SCHEME_COMPLEXP(o)) {
Scheme_Object *r = _scheme_complex_real_part(o);
Scheme_Object *i = _scheme_complex_imaginary_part(o);
Scheme_Object *m2;
m2 = scheme_bin_plus(scheme_bin_mult(r, r),
scheme_bin_mult(i, i));
Scheme_Object *a[1], *q;
a[0] = r;
r = scheme_abs(1, a);
a[0] = i;
i = scheme_abs(1, a);
return scheme_sqrt(1, &m2);
if (SAME_OBJ(r, scheme_make_integer(0)))
return i;
if (scheme_bin_lt(i, r)) {
Scheme_Object *tmp;
tmp = i;
i = r;
r = tmp;
}
a[0] = r;
if (SCHEME_TRUEP(scheme_zero_p(1, a))) {
a[0] = i;
return scheme_exact_to_inexact(1, a);
}
q = scheme_bin_div(r, i);
q = scheme_bin_plus(scheme_make_integer(1),
scheme_bin_mult(q, q));
a[0] = q;
return scheme_bin_mult(i, scheme_sqrt(1, a));
} else
return scheme_abs(1, argv);
}

6
src/mzscheme/src/port.c
View File

@ -1180,7 +1180,7 @@ static void register_port_wait()
evt_output_port_p, 1);
}
static int pipe_char_count(Scheme_Object *p)
XFORM_NONGCING static int pipe_char_count(Scheme_Object *p)
{
if (p) {
Scheme_Pipe *pipe;
@ -1202,7 +1202,7 @@ static void post_progress(Scheme_Input_Port *ip)
ip->progress_evt = NULL;
}
static void inc_pos(Scheme_Port *ip, int a)
XFORM_NONGCING static void inc_pos(Scheme_Port *ip, int a)
{
ip->column += a;
ip->readpos += a;
@ -1232,7 +1232,7 @@ static Scheme_Object *quick_plus(Scheme_Object *s, long v)
#define state_len(state) ((state >> 3) & 0x7)
static void do_count_lines(Scheme_Port *ip, const char *buffer, long offset, long got)
XFORM_NONGCING static void do_count_lines(Scheme_Port *ip, const char *buffer, long offset, long got)
{
long i;
int c, degot = 0;

7
src/mzscheme/src/schemef.h
View File

@ -524,8 +524,8 @@ MZ_EXTERN mzchar *scheme_utf8_decode_to_buffer(const unsigned char *s, int len,
mzchar *buf, int blen);
MZ_EXTERN mzchar *scheme_utf8_decode_to_buffer_len(const unsigned char *s, int len,
mzchar *buf, int blen, long *rlen);
MZ_EXTERN int scheme_utf8_decode_count(const unsigned char *s, int start, int end,
int *_state, int might_continue, int permissive);
XFORM_NONGCING MZ_EXTERN int scheme_utf8_decode_count(const unsigned char *s, int start, int end,
int *_state, int might_continue, int permissive);
MZ_EXTERN int scheme_utf8_encode(const unsigned int *us, int start, int end,
unsigned char *s, int dstart,
@ -852,9 +852,6 @@ MZ_EXTERN Scheme_Object *scheme_make_modidx(Scheme_Object *path,
Scheme_Object *base,
Scheme_Object *resolved);
MZ_EXTERN Scheme_Object *scheme_declare_module(Scheme_Object *shape, Scheme_Invoke_Proc ivk,
Scheme_Invoke_Proc sivk, void *data, Scheme_Env *env);
MZ_EXTERN Scheme_Object *scheme_apply_for_syntax_in_env(Scheme_Object *proc, Scheme_Env *env);
MZ_EXTERN Scheme_Object *scheme_dynamic_require(int argc, Scheme_Object *argv[]);

6
src/mzscheme/src/schemex.h
View File

@ -429,8 +429,8 @@ mzchar *(*scheme_utf8_decode_to_buffer)(const unsigned char *s, int len,
mzchar *buf, int blen);
mzchar *(*scheme_utf8_decode_to_buffer_len)(const unsigned char *s, int len,
mzchar *buf, int blen, long *rlen);
int (*scheme_utf8_decode_count)(const unsigned char *s, int start, int end,
int *_state, int might_continue, int permissive);
XFORM_NONGCING MZ_EXTERN;
int *_state, int might_continue, int permissive);
int (*scheme_utf8_encode)(const unsigned int *us, int start, int end,
unsigned char *s, int dstart,
char utf16);
@ -703,8 +703,6 @@ void (*scheme_protect_primitive_provide)(Scheme_Env *env, Scheme_Object *name);
Scheme_Object *(*scheme_make_modidx)(Scheme_Object *path,
Scheme_Object *base,
Scheme_Object *resolved);
Scheme_Object *(*scheme_declare_module)(Scheme_Object *shape, Scheme_Invoke_Proc ivk,
Scheme_Invoke_Proc sivk, void *data, Scheme_Env *env);
Scheme_Object *(*scheme_apply_for_syntax_in_env)(Scheme_Object *proc, Scheme_Env *env);
Scheme_Object *(*scheme_dynamic_require)(int argc, Scheme_Object *argv[]);
/*========================================================================*/

3
src/mzscheme/src/schemex.inc
View File

@ -285,7 +285,7 @@
scheme_extension_table->scheme_utf8_decode_prefix = scheme_utf8_decode_prefix;
scheme_extension_table->scheme_utf8_decode_to_buffer = scheme_utf8_decode_to_buffer;
scheme_extension_table->scheme_utf8_decode_to_buffer_len = scheme_utf8_decode_to_buffer_len;
scheme_extension_table->scheme_utf8_decode_count = scheme_utf8_decode_count;
scheme_extension_table->MZ_EXTERN = MZ_EXTERN;
scheme_extension_table->scheme_utf8_encode = scheme_utf8_encode;
scheme_extension_table->scheme_utf8_encode_all = scheme_utf8_encode_all;
scheme_extension_table->scheme_utf8_encode_to_buffer = scheme_utf8_encode_to_buffer;
@ -475,7 +475,6 @@
scheme_extension_table->scheme_finish_primitive_module = scheme_finish_primitive_module;
scheme_extension_table->scheme_protect_primitive_provide = scheme_protect_primitive_provide;
scheme_extension_table->scheme_make_modidx = scheme_make_modidx;
scheme_extension_table->scheme_declare_module = scheme_declare_module;
scheme_extension_table->scheme_apply_for_syntax_in_env = scheme_apply_for_syntax_in_env;
scheme_extension_table->scheme_dynamic_require = scheme_dynamic_require;
scheme_extension_table->scheme_intern_symbol = scheme_intern_symbol;

3
src/mzscheme/src/schemexm.h
View File

@ -285,7 +285,7 @@
#define scheme_utf8_decode_prefix (scheme_extension_table->scheme_utf8_decode_prefix)
#define scheme_utf8_decode_to_buffer (scheme_extension_table->scheme_utf8_decode_to_buffer)
#define scheme_utf8_decode_to_buffer_len (scheme_extension_table->scheme_utf8_decode_to_buffer_len)
#define scheme_utf8_decode_count (scheme_extension_table->scheme_utf8_decode_count)
#define MZ_EXTERN (scheme_extension_table->MZ_EXTERN)
#define scheme_utf8_encode (scheme_extension_table->scheme_utf8_encode)
#define scheme_utf8_encode_all (scheme_extension_table->scheme_utf8_encode_all)
#define scheme_utf8_encode_to_buffer (scheme_extension_table->scheme_utf8_encode_to_buffer)
@ -475,7 +475,6 @@
#define scheme_finish_primitive_module (scheme_extension_table->scheme_finish_primitive_module)
#define scheme_protect_primitive_provide (scheme_extension_table->scheme_protect_primitive_provide)
#define scheme_make_modidx (scheme_extension_table->scheme_make_modidx)
#define scheme_declare_module (scheme_extension_table->scheme_declare_module)
#define scheme_apply_for_syntax_in_env (scheme_extension_table->scheme_apply_for_syntax_in_env)
#define scheme_dynamic_require (scheme_extension_table->scheme_dynamic_require)
#define scheme_intern_symbol (scheme_extension_table->scheme_intern_symbol)

52
src/mzscheme/src/schpriv.h
View File

@ -593,7 +593,8 @@ void scheme_extend_module_rename(Scheme_Object *rn, Scheme_Object *modname,
void scheme_extend_module_rename_with_kernel(Scheme_Object *rn, Scheme_Object *nominal_src);
void scheme_save_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info);
void scheme_do_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info,
Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to);
Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to,
Scheme_Hash_Table *export_registry);
void scheme_remove_module_rename(Scheme_Object *mrn,
Scheme_Object *localname);
void scheme_append_module_rename(Scheme_Object *src, Scheme_Object *dest);
@ -626,9 +627,11 @@ Scheme_Object *scheme_stx_property(Scheme_Object *_stx,
Scheme_Object *val);
Scheme_Object *scheme_stx_phase_shift(Scheme_Object *stx, long shift,
Scheme_Object *old_midx, Scheme_Object *new_midx);
Scheme_Object *old_midx, Scheme_Object *new_midx,
Scheme_Hash_Table *export_registry);
Scheme_Object *scheme_stx_phase_shift_as_rename(long shift,
Scheme_Object *old_midx, Scheme_Object *new_midx);
Scheme_Object *old_midx, Scheme_Object *new_midx,
Scheme_Hash_Table *export_registry);
int scheme_stx_list_length(Scheme_Object *list);
int scheme_stx_proper_list_length(Scheme_Object *list);
@ -1420,7 +1423,7 @@ Scheme_Object *scheme_named_map_1(char *,
Scheme_Object *(*fun)(Scheme_Object*, Scheme_Object *form),
Scheme_Object *lst, Scheme_Object *form);
int scheme_strncmp(const char *a, const char *b, int len);
XFORM_NONGCING int scheme_strncmp(const char *a, const char *b, int len);
#define _scheme_make_char(ch) scheme_make_character(ch)
@ -2001,6 +2004,7 @@ struct Scheme_Env {
Scheme_Hash_Table *module_registry; /* symbol -> module ; loaded modules,
shared with modules in same space */
Scheme_Hash_Table *export_registry; /* symbol -> module-exports */
Scheme_Object *insp; /* instantiation-time inspector, for granting
protected access and certificates */
@ -2049,9 +2053,9 @@ typedef struct Scheme_Module
Scheme_Object *modname;
Scheme_Object *et_requires; /* list of module access paths */
Scheme_Object *requires; /* list of module access paths */
Scheme_Object *tt_requires; /* list of module access paths */
Scheme_Object *et_requires; /* list of symbol-or-module-path-index */
Scheme_Object *requires; /* list of symbol-or-module-path-index */
Scheme_Object *tt_requires; /* list of symbol-or-module-path-index */
Scheme_Invoke_Proc prim_body;
Scheme_Invoke_Proc prim_et_body;
@ -2060,21 +2064,13 @@ typedef struct Scheme_Module
Scheme_Object *et_body; /* list of (vector list-of-names expr depth-int resolve-prefix) */
char functional, et_functional, tt_functional, no_cert;
struct Scheme_Module_Exports *me;
Scheme_Object **provides; /* symbols (extenal names) */
Scheme_Object **provide_srcs; /* module access paths, #f for self */
Scheme_Object **provide_src_names; /* symbols (original internal names) */
char *provide_protects; /* 1 => protected, 0 => not */
int num_provides;
int num_var_provides; /* non-syntax listed first in provides */
int reprovide_kernel; /* if true, extend provides with kernel's */
Scheme_Object *kernel_exclusion; /* we allow one exn, but it must be shadowed */
Scheme_Object **indirect_provides; /* symbols (internal names) */
int num_indirect_provides;
Scheme_Object *src_modidx; /* the one used in marshalled syntax */
Scheme_Object *self_modidx;
Scheme_Hash_Table *accessible;
@ -2094,6 +2090,26 @@ typedef struct Scheme_Module
Scheme_Object *rn_stx, *et_rn_stx, *tt_rn_stx;
} Scheme_Module;
typedef struct Scheme_Module_Exports
{
/* Scheme_Module_Exports is separate from Scheme_Module
so that we can create a global table mapping export
keys to exports. This mapping is used to lazily
unmarshal syntax-object context. */
MZTAG_IF_REQUIRED
Scheme_Object **provides; /* symbols (extenal names) */
Scheme_Object **provide_srcs; /* module access paths, #f for self */
Scheme_Object **provide_src_names; /* symbols (original internal names) */
int num_provides;
int num_var_provides; /* non-syntax listed first in provides */
int reprovide_kernel; /* if true, extend provides with kernel's */
Scheme_Object *kernel_exclusion; /* we allow one exn, but it must be shadowed */
Scheme_Object *src_modidx; /* the one used in marshalled syntax */
} Scheme_Module_Exports;
typedef struct Scheme_Modidx {
Scheme_Object so; /* scheme_module_index_type */
@ -2125,7 +2141,7 @@ Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env);
Scheme_Env *scheme_new_module_env(Scheme_Env *env, Scheme_Module *m, int new_exp_module_tree);
int scheme_is_module_env(Scheme_Comp_Env *env);
Scheme_Object *scheme_module_resolve(Scheme_Object *modidx);
Scheme_Object *scheme_module_resolve(Scheme_Object *modidx, int load_it);
Scheme_Env *scheme_module_access(Scheme_Object *modname, Scheme_Env *env, int rev_mod_phase);
void scheme_module_force_lazy(Scheme_Env *env, int previous);

4
src/mzscheme/src/schvers.h
View File

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 350
#define MZSCHEME_VERSION_MINOR 1
#define MZSCHEME_VERSION_MINOR 2
#define MZSCHEME_VERSION "350.1" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "350.2" _MZ_SPECIAL_TAG

39
src/mzscheme/src/startup.inc
View File

@ -2867,14 +2867,29 @@
"(define(make-standard-module-name-resolver orig-namespace)"
"(define planet-resolver #f)"
"(define standard-module-name-resolver"
"(lambda(s relto stx)"
"(case-lambda "
"((s) "
"(when planet-resolver"
"(planet-resolver s))"
"(let((ht(hash-table-get"
" -module-hash-table-table"
"(namespace-module-registry(current-namespace))"
"(lambda()"
"(let((ht(make-hash-table)))"
"(hash-table-put! -module-hash-table-table"
"(namespace-module-registry(current-namespace))"
" ht)"
" ht)))))"
"(hash-table-put! ht s 'attach)))"
"((s relto stx)(standard-module-name-resolver s relto stx #t))"
"((s relto stx load?)"
"(cond"
"((and(pair? s)(eq?(car s) 'planet))"
"(unless planet-resolver"
"(parameterize((current-namespace orig-namespace))"
" (set! planet-resolver (dynamic-require '(lib \"resolver.ss\" \"planet\") 'planet-module-name-resolver))))"
"(planet-resolver s relto stx))"
"(s"
"(planet-resolver s relto stx load?))"
"(else"
"(let((get-dir(lambda()"
"(or(and relto"
"(if(eq? relto -prev-relto)"
@ -2993,6 +3008,7 @@
"(namespace-module-registry(current-namespace))"
" ht)"
" ht)))))"
"(when load?"
"(let((got(hash-table-get ht modname(lambda() #f))))"
"(when got"
"(unless(or(symbol? got)(equal? suffix got))"
@ -3023,7 +3039,7 @@
"((current-load/use-compiled) "
" filename "
"(string->symbol(bytes->string/latin-1(path->bytes no-sfx)))))))"
"(hash-table-put! ht modname suffix)))"
"(hash-table-put! ht modname suffix))))"
"(when(and(not(vector? s-parsed))"
"(or(string? s)"
"(and(pair? s)"
@ -3039,20 +3055,7 @@
" abase"
" modname"
" suffix)))"
" modname)))))))"
"(else"
"(when planet-resolver"
"(planet-resolver s relto stx))"
"(let((ht(hash-table-get"
" -module-hash-table-table"
"(namespace-module-registry(current-namespace))"
"(lambda()"
"(let((ht(make-hash-table)))"
"(hash-table-put! -module-hash-table-table"
"(namespace-module-registry(current-namespace))"
" ht)"
" ht)))))"
"(hash-table-put! ht relto 'attach))))))"
" modname)))))))))))"
" standard-module-name-resolver)"
"(define find-library-collection-paths"
"(case-lambda"

107
src/mzscheme/src/startup.ss
View File

@ -3303,7 +3303,24 @@
(define (make-standard-module-name-resolver orig-namespace)
(define planet-resolver #f)
(define standard-module-name-resolver
(lambda (s relto stx)
(case-lambda
[(s)
;; Just register s as loaded
(when planet-resolver
;; Let planet resolver register, too:
(planet-resolver s))
(let ([ht (hash-table-get
-module-hash-table-table
(namespace-module-registry (current-namespace))
(lambda ()
(let ([ht (make-hash-table)])
(hash-table-put! -module-hash-table-table
(namespace-module-registry (current-namespace))
ht)
ht)))])
(hash-table-put! ht s 'attach))]
[(s relto stx) (standard-module-name-resolver s relto stx #t)]
[(s relto stx load?)
;; If stx is not #f, raise syntax error for ill-formed paths
;; If s is #f, call to resolver is a notification from namespace-attach-module
(cond
@ -3311,8 +3328,8 @@
(unless planet-resolver
(parameterize ([current-namespace orig-namespace])
(set! planet-resolver (dynamic-require '(lib "resolver.ss" "planet") 'planet-module-name-resolver))))
(planet-resolver s relto stx)]
[s
(planet-resolver s relto stx load?)]
[else
(let ([get-dir (lambda ()
(or (and relto
(if (eq? relto -prev-relto)
@ -3435,39 +3452,40 @@
ht)
ht)))])
;; Loaded already?
(let ([got (hash-table-get ht modname (lambda () #f))])
(when got
;; Check the suffix, which gets lost when creating a key:
(unless (or (symbol? got) (equal? suffix got))
(error
'standard-module-name-resolver
"module previously loaded with suffix ~s, cannot load with suffix ~s: ~e"
(if (eq? #t got) "" got)
(if (eq? #t suffix) "" suffix)
filename)))
(unless got
;; Currently loading?
(let ([l (continuation-mark-set->list
(current-continuation-marks)
-loading-filename)]
[ns (current-namespace)])
(for-each
(lambda (s)
(when (and (equal? (cdr s) normal-filename)
(eq? (car s) ns))
(error
'standard-module-name-resolver
"cycle in loading at ~e: ~e"
filename
(map cdr (reverse (cons s l))))))
l))
(let ([prefix (string->symbol abase)])
(with-continuation-mark -loading-filename (cons (current-namespace) normal-filename)
(parameterize ([current-module-name-prefix prefix])
((current-load/use-compiled)
filename
(string->symbol (bytes->string/latin-1 (path->bytes no-sfx)))))))
(hash-table-put! ht modname suffix)))
(when load?
(let ([got (hash-table-get ht modname (lambda () #f))])
(when got
;; Check the suffix, which gets lost when creating a key:
(unless (or (symbol? got) (equal? suffix got))
(error
'standard-module-name-resolver
"module previously loaded with suffix ~s, cannot load with suffix ~s: ~e"
(if (eq? #t got) "" got)
(if (eq? #t suffix) "" suffix)
filename)))
(unless got
;; Currently loading?
(let ([l (continuation-mark-set->list
(current-continuation-marks)
-loading-filename)]
[ns (current-namespace)])
(for-each
(lambda (s)
(when (and (equal? (cdr s) normal-filename)
(eq? (car s) ns))
(error
'standard-module-name-resolver
"cycle in loading at ~e: ~e"
filename
(map cdr (reverse (cons s l))))))
l))
(let ([prefix (string->symbol abase)])
(with-continuation-mark -loading-filename (cons (current-namespace) normal-filename)
(parameterize ([current-module-name-prefix prefix])
((current-load/use-compiled)
filename
(string->symbol (bytes->string/latin-1 (path->bytes no-sfx)))))))
(hash-table-put! ht modname suffix))))
;; If a `lib' path, cache pathname manipulations
(when (and (not (vector? s-parsed))
(or (string? s)
@ -3485,22 +3503,7 @@
modname
suffix)))
;; Result is the module name:
modname))))))]
[else
;; Just register relto as loaded
(when planet-resolver
;; Let planet resolver register, too:
(planet-resolver s relto stx))
(let ([ht (hash-table-get
-module-hash-table-table
(namespace-module-registry (current-namespace))
(lambda ()
(let ([ht (make-hash-table)])
(hash-table-put! -module-hash-table-table
(namespace-module-registry (current-namespace))
ht)
ht)))])
(hash-table-put! ht relto 'attach))])))
modname))))))])]))
standard-module-name-resolver)
(define find-library-collection-paths

16
src/mzscheme/src/string.c
View File

@ -268,14 +268,14 @@ static int mz_char_strcmp(const char *who, const mzchar *str1, int l1, const mzc
static int mz_char_strcmp_ci(const char *who, const mzchar *str1, int l1, const mzchar *str2, int l2, int locale, int size_shortcut);
static int mz_strcmp(const char *who, unsigned char *str1, int l1, unsigned char *str2, int l2);
static int utf8_decode_x(const unsigned char *s, int start, int end,
unsigned int *us, int dstart, int dend,
long *ipos, long *jpos,
char compact, char utf16,
int *state, int might_continue, int permissive);
static int utf8_encode_x(const unsigned int *us, int start, int end,
unsigned char *s, int dstart, int dend,
long *_ipos, long *_opos, char utf16);
XFORM_NONGCING static int utf8_decode_x(const unsigned char *s, int start, int end,
unsigned int *us, int dstart, int dend,
long *ipos, long *jpos,
char compact, char utf16,
int *state, int might_continue, int permissive);
XFORM_NONGCING static int utf8_encode_x(const unsigned int *us, int start, int end,
unsigned char *s, int dstart, int dend,
long *_ipos, long *_opos, char utf16);
static char *string_to_from_locale(int to_bytes,
char *in, int delta, int len,

70
src/mzscheme/src/stxobj.c
View File

@ -213,8 +213,10 @@ static Module_Renames *krn;
simple lexical renames (not ribs) and marks, only, and it's
inserted into a chain heuristically
- A wrap-elem (box (vector <num> <midx> <midx>)) is a phase shift
by <num>, remapping the first <midx> to the second <midx>
- A wrap-elem (box (vector <num> <midx> <midx> <export-registry>))
is a phase shift by <num>, remapping the first <midx> to the
second <midx>; the <export-registry> part is for finding
modules to unmarshal import renamings
- A wrap-elem '* is a mark barrier, which is applied to the
result of an expansion so that top-level marks do not
@ -1327,14 +1329,16 @@ Scheme_Hash_Table *scheme_module_rename_marked_names(Scheme_Object *rn)
}
static void unmarshal_rename(Module_Renames *mrn,
Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to)
Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to,
Scheme_Hash_Table *export_registry)
{
Scheme_Object *l;
mrn->needs_unmarshal = 0;
for (l = mrn->unmarshal_info; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
scheme_do_module_rename_unmarshal((Scheme_Object *)mrn, SCHEME_CAR(l),
modidx_shift_from, modidx_shift_to);
modidx_shift_from, modidx_shift_to,
export_registry);
}
}
@ -1402,22 +1406,25 @@ Scheme_Object *scheme_add_mark_barrier(Scheme_Object *o)
return scheme_add_rename(o, barrier_symbol);
}
Scheme_Object *scheme_stx_phase_shift_as_rename(long shift, Scheme_Object *old_midx, Scheme_Object *new_midx)
Scheme_Object *scheme_stx_phase_shift_as_rename(long shift, Scheme_Object *old_midx, Scheme_Object *new_midx,
Scheme_Hash_Table *export_registry)
{
if (shift || new_midx) {
if (shift || new_midx || export_registry) {
Scheme_Object *vec;
if (last_phase_shift
&& ((vec = SCHEME_BOX_VAL(last_phase_shift)))
&& (SCHEME_VEC_ELS(vec)[0] == scheme_make_integer(shift))
&& (SCHEME_VEC_ELS(vec)[1] == (new_midx ? old_midx : scheme_false))
&& (SCHEME_VEC_ELS(vec)[2] == (new_midx ? new_midx : scheme_false))) {
&& (SCHEME_VEC_ELS(vec)[2] == (new_midx ? new_midx : scheme_false))
&& (SCHEME_VEC_ELS(vec)[3] == (export_registry ? (Scheme_Object *)export_registry : scheme_false))) {
/* use the old one */
} else {
vec = scheme_make_vector(3, NULL);
vec = scheme_make_vector(4, NULL);
SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(shift);
SCHEME_VEC_ELS(vec)[1] = (new_midx ? old_midx : scheme_false);
SCHEME_VEC_ELS(vec)[2] = (new_midx ? new_midx : scheme_false);
SCHEME_VEC_ELS(vec)[3] = (export_registry ? (Scheme_Object *)export_registry : scheme_false);
last_phase_shift = scheme_box(vec);
}
@ -1428,14 +1435,15 @@ Scheme_Object *scheme_stx_phase_shift_as_rename(long shift, Scheme_Object *old_m
}
Scheme_Object *scheme_stx_phase_shift(Scheme_Object *stx, long shift,
Scheme_Object *old_midx, Scheme_Object *new_midx)
Scheme_Object *old_midx, Scheme_Object *new_midx,
Scheme_Hash_Table *export_registry)
/* Shifts the phase on a syntax object in a module. A 0 shift might be
used just to re-direct relative module paths. new_midx might be
NULL to shift without redirection. */
NULL to shift without redirection. And so on. */
{
Scheme_Object *ps;
ps = scheme_stx_phase_shift_as_rename(shift, old_midx, new_midx);
ps = scheme_stx_phase_shift_as_rename(shift, old_midx, new_midx, export_registry);
if (ps)
return scheme_add_rename(stx, ps);
else
@ -1781,8 +1789,8 @@ int scheme_stx_certified(Scheme_Object *stx, Scheme_Object *extra_certs,
else
cert_modidx = certs->modidx;
a = scheme_module_resolve(home_modidx);
b = scheme_module_resolve(cert_modidx);
a = scheme_module_resolve(home_modidx, 0);
b = scheme_module_resolve(cert_modidx, 0);
} else
a = b = NULL;
@ -2057,7 +2065,7 @@ Scheme_Object *scheme_stx_cert(Scheme_Object *o, Scheme_Object *mark, Scheme_Env
else
cert = INACTIVE_CERTS(stx);
cert = cons_cert(mark, menv->link_midx ? menv->link_midx : menv->module->src_modidx,
cert = cons_cert(mark, menv->link_midx ? menv->link_midx : menv->module->me->src_modidx,
menv->module->insp, key, cert);
if (active) {
@ -2665,6 +2673,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
Scheme_Lexical_Rib *rib = NULL, *did_rib = NULL;
long orig_phase = phase;
Scheme_Object *bdg = NULL;
Scheme_Hash_Table *export_registry = NULL;
if (_wraps) {
WRAP_POS_COPY(wraps, *_wraps);
@ -2718,7 +2727,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
Scheme_Object *rename, *nominal = NULL, *glob_id;
if (mrn->needs_unmarshal)
unmarshal_rename(mrn, modidx_shift_from, modidx_shift_to);
unmarshal_rename(mrn, modidx_shift_from, modidx_shift_to, export_registry);
if (mrn->marked_names) {
/* Resolve based on rest of wraps: */
@ -2830,6 +2839,13 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
modidx_shift_from = src;
}
{
Scheme_Object *er;
er = SCHEME_VEC_ELS(vec)[3];
if (SCHEME_TRUEP(er))
export_registry = (Scheme_Hash_Table *)er;
}
} else if (rib || (SCHEME_VECTORP(WRAP_POS_FIRST(wraps))
&& !no_lexical)) {
/* Lexical rename: */
@ -3079,8 +3095,8 @@ int scheme_stx_free_eq(Scheme_Object *a, Scheme_Object *b, long phase)
a = resolve_env(NULL, a, phase, 1, NULL, NULL);
b = resolve_env(NULL, b, phase, 1, NULL, NULL);
a = scheme_module_resolve(a);
b = scheme_module_resolve(b);
a = scheme_module_resolve(a, 0);
b = scheme_module_resolve(b, 0);
/* Same binding environment? */
return SAME_OBJ(a, b);
@ -3112,8 +3128,8 @@ int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, long phase)
a = resolve_env(NULL, a, phase, 1, NULL, NULL);
b = resolve_env(NULL, b, phase, 1, NULL, NULL);
a = scheme_module_resolve(a);
b = scheme_module_resolve(b);
a = scheme_module_resolve(a, 0);
b = scheme_module_resolve(b, 0);
/* Same binding environment? */
return SAME_OBJ(a, b);
@ -3254,7 +3270,7 @@ Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve)
}
if (SCHEME_TRUEP(srcmod) && resolve)
srcmod = scheme_module_resolve(srcmod);
srcmod = scheme_module_resolve(srcmod, 0);
return srcmod;
}
@ -3993,6 +4009,18 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
}
/* If l is the end, don't need the phase shift */
if (!WRAP_POS_END_P(l)) {
/* Need the phase shift, but drop the export table, if any: */
Scheme_Object *aa;
aa = SCHEME_BOX_VAL(a);
if (SCHEME_TRUEP(SCHEME_VEC_ELS(aa)[3])) {
a = scheme_make_vector(4, NULL);
SCHEME_VEC_ELS(a)[0] = SCHEME_VEC_ELS(aa)[0];
SCHEME_VEC_ELS(a)[1] = SCHEME_VEC_ELS(aa)[1];
SCHEME_VEC_ELS(a)[2] = SCHEME_VEC_ELS(aa)[2];
SCHEME_VEC_ELS(a)[3] = scheme_false;
a = scheme_box(a);
}
stack = CONS(a, stack);
stack_size++;
}
@ -5604,7 +5632,7 @@ static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **ar
/* Imported */
int pos;
m = scheme_module_resolve(m);
m = scheme_module_resolve(m, 0);
pos = scheme_module_export_position(m, scheme_get_env(NULL), a);
if (pos < 0)
return scheme_false;

1
src/mzscheme/src/stypes.h
View File

@ -215,6 +215,7 @@ enum {
scheme_rt_native_code, /* 194 */
scheme_rt_native_code_plus_case, /* 195 */
scheme_rt_jitter_data, /* 196 */
scheme_rt_module_exports, /* 197 */
#endif
_scheme_last_type_

1
src/mzscheme/src/type.c
View File

@ -519,6 +519,7 @@ void scheme_register_traversers(void)
GC_REG_TRAV(scheme_stx_type, stx_val);
GC_REG_TRAV(scheme_stx_offset_type, stx_off_val);
GC_REG_TRAV(scheme_module_type, module_val);
GC_REG_TRAV(scheme_rt_module_exports, module_exports_val);
GC_REG_TRAV(scheme_module_index_type, modidx_val);
GC_REG_TRAV(scheme_security_guard_type, guard_val);