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

updates from mzscheme->scheme

Browse Source 
svn: r13751
This commit is contained in:
Jon Rafkind 2009-02-19 22:26:10 +00:00
parent 09c6c96099
commit 7b3d069f47
1 changed files with 94 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

173
collects/honu/main.ss
View File

@ -1,14 +1,18 @@
(module main "private/mzscheme.ss" #lang scheme/base
(require (for-syntax
syntax/stx
scheme/base
syntax/kerncase
syntax/define
syntax/context
syntax/name
"private/ops.ss"
"private/util.ss"
"private/contexts.ss"
))
(require-for-syntax syntax/stx
"private/ops.ss"
"private/util.ss"
syntax/kerncase
syntax/name
"private/contexts.ss")
(begin-for-syntax (begin-for-syntax
;; these definitions are used as stop-lists in local-expand ;; these definitions are used as stop-lists in local-expand
(define kernel-forms (kernel-form-identifier-list)) (define kernel-forms (kernel-form-identifier-list))
(define prop-expand-stop-forms (list* #'honu-typed (define prop-expand-stop-forms (list* #'honu-typed
@ -20,6 +24,7 @@
(define type-name-expand-stop-forms (list (define type-name-expand-stop-forms (list
#'honu-type-name)) #'honu-type-name))
;; -------------------------------------------------------- ;; --------------------------------------------------------
;; Transformer procedure property and basic struct ;; Transformer procedure property and basic struct
@ -64,7 +69,7 @@
[(forall (id ...) rhs bindings) [(forall (id ...) rhs bindings)
(append (map syntax-e (syntax->list #'(id ...))) (append (map syntax-e (syntax->list #'(id ...)))
(list '>-> (format-type #'rhs)))] (list '>-> (format-type #'rhs)))]
[_else `(??? ,(syntax-object->datum t))]))) [_else `(??? ,(syntax->datum t))])))
;; -------------------------------------------------------- ;; --------------------------------------------------------
;; Parsing blocks ;; Parsing blocks
@ -83,7 +88,7 @@
(and (identifier? stx) (and (identifier? stx)
(not (ormap (lambda (i) (delim-identifier=? stx i)) (list #'\; #'\,))) (not (ormap (lambda (i) (delim-identifier=? stx i)) (list #'\; #'\,)))
(not (operator? stx)))) (not (operator? stx))))
(define (get-transformer stx) (define (get-transformer stx)
;; if its an identifier and bound to a transformer return it ;; if its an identifier and bound to a transformer return it
(define (bound-transformer stx) (define (bound-transformer stx)
@ -113,7 +118,7 @@
[else (loop (cdr l))])))] [else (loop (cdr l))])))]
[(and (stx-pair? first) [(and (stx-pair? first)
(identifier? (stx-car first)) (identifier? (stx-car first))
(module-identifier=? #'#%angles (stx-car first))) (free-identifier=? #'#%angles (stx-car first)))
(let ([v (syntax-local-value (stx-car first) (lambda () #f))]) (let ([v (syntax-local-value (stx-car first) (lambda () #f))])
(and (honu-transformer? v) v))] (and (honu-transformer? v) v))]
[else #f])))) [else #f]))))
@ -133,7 +138,8 @@
=> (lambda (transformer) => (lambda (transformer)
(let-values ([(code rest) (transformer body ctx)]) (let-values ([(code rest) (transformer body ctx)])
(k code rest)))] (k code rest)))]
[else (let-values ([(expr-stxs after-expr terminator) (extract-until body (list #'\;))]) [else (let-values ([(expr-stxs after-expr terminator)
(extract-until body (list #'\;))])
(unless expr-stxs (unless expr-stxs
(raise-syntax-error (raise-syntax-error
#f #f
@ -177,7 +183,7 @@
;; Since we're parsing an expression in a ;; Since we're parsing an expression in a
;; declaration context, we're responsible for ;; declaration context, we're responsible for
;; getting the whole expression: ;; getting the whole expression:
(let ([placeholder (datum->syntax-object #f (gensym))]) (let ([placeholder (datum->syntax #f (gensym))])
(let-values ([(expr-stxs after-expr terminator) (extract-until (cons placeholder rest) (list #'\;))]) (let-values ([(expr-stxs after-expr terminator) (extract-until (cons placeholder rest) (list #'\;))])
(unless expr-stxs (unless expr-stxs
(raise-syntax-error (raise-syntax-error
@ -188,11 +194,11 @@
(cond (cond
[(eq? in-expr placeholder) expr] [(eq? in-expr placeholder) expr]
[(syntax? in-expr) [(syntax? in-expr)
(datum->syntax-object in-expr (datum->syntax in-expr
(loop (syntax-e in-expr)) (loop (syntax-e in-expr))
in-expr in-expr
in-expr in-expr
in-expr)] in-expr)]
[(pair? in-expr) (cons (loop (car in-expr)) [(pair? in-expr) (cons (loop (car in-expr))
(loop (cdr in-expr)))] (loop (cdr in-expr)))]
[else in-expr]))]) [else in-expr]))])
@ -272,9 +278,9 @@
(delim-identifier=? #'#%parens id) (delim-identifier=? #'#%parens id)
(delim-identifier=? #'#%angles id)))) (delim-identifier=? #'#%angles id))))
(and (identifier? (stx-car stx)) (and (identifier? (stx-car stx))
(hash-table-get op-table (hash-ref op-table
(syntax-e (stx-car stx)) (syntax-e (stx-car stx))
(lambda () #f)))) (lambda () #f))))
(raise-syntax-error (raise-syntax-error
'expression 'expression
"expected an operator, but found something else" "expected an operator, but found something else"
@ -362,8 +368,8 @@
[(not (op? (stx-car seq))) [(not (op? (stx-car seq)))
(loop (cdr seq) before op (cons (car seq) since))] (loop (cdr seq) before op (cons (car seq) since))]
[((if (prefix? op) >= >) [((if (prefix? op) >= >)
(hash-table-get precedence-table (prec-key (car seq)) (lambda () 0)) (hash-ref precedence-table (prec-key (car seq)) (lambda () 0))
(hash-table-get precedence-table (prec-key op) (lambda () 0))) (hash-ref precedence-table (prec-key op) (lambda () 0)))
(loop (cdr seq) (loop (cdr seq)
(if op (if op
(append since (list op) before) (append since (list op) before)
@ -550,11 +556,11 @@
(stx-car orig-stx) (stx-car orig-stx)
#'id)) #'id))
(if (and (or (value-definition-context? ctx) (if (and (or (value-definition-context? ctx)
(not (module-identifier=? #'id #'function))) (not (free-identifier=? #'id #'function)))
(not (function-definition-context? ctx)) (not (function-definition-context? ctx))
(not (prototype-context? ctx)) (not (prototype-context? ctx))
(identifier? (stx-car #'rest)) (identifier? (stx-car #'rest))
(module-identifier=? #'set! (stx-car #'rest))) (free-identifier=? #'set! (stx-car #'rest)))
;; -- Non-procedure declaration ;; -- Non-procedure declaration
(if (function-definition-context? ctx) (if (function-definition-context? ctx)
(raise-syntax-error (raise-syntax-error
@ -595,7 +601,7 @@
(with-syntax ([((arg arg-type arg-type-name arg-pred-id arg-protect-id) ...) args] (with-syntax ([((arg arg-type arg-type-name arg-pred-id arg-protect-id) ...) args]
[(temp-id ...) (generate-temporaries (map car args))] [(temp-id ...) (generate-temporaries (map car args))]
[def-id (if (and (not (definition-context? ctx)) [def-id (if (and (not (definition-context? ctx))
(module-identifier=? #'id #'function)) (free-identifier=? #'id #'function))
(or (syntax-local-infer-name #'id) (or (syntax-local-infer-name #'id)
(car (generate-temporaries '(function)))) (car (generate-temporaries '(function))))
#'id)]) #'id)])
@ -614,7 +620,7 @@
(define-typed arg #f id arg-type arg-type-name arg-pred-id arg-protect-id temp-id) ... (define-typed arg #f id arg-type arg-type-name arg-pred-id arg-protect-id temp-id) ...
(honu-unparsed-block def-id type-name type-name-expr pred-id #t . body))))]) (honu-unparsed-block def-id type-name type-name-expr pred-id #t . body))))])
(if (and (not (definition-context? ctx)) (if (and (not (definition-context? ctx))
(module-identifier=? #'id #'function)) (free-identifier=? #'id #'function))
;; Anonymous function: ;; Anonymous function:
;; We may have to continue parsing... ;; We may have to continue parsing...
(finish-parsing-expression "anonymous function" (finish-parsing-expression "anonymous function"
@ -663,7 +669,7 @@
(let-values ([(args-stx ->-stx result-stx) (let-values ([(args-stx ->-stx result-stx)
(let loop ([stx (stx-cdr (stx-car form))][args null]) (let loop ([stx (stx-cdr (stx-car form))][args null])
(if (and (identifier? (stx-car stx)) (if (and (identifier? (stx-car stx))
(module-identifier=? #'-> (stx-car stx))) (free-identifier=? #'-> (stx-car stx)))
(values (reverse args) (stx-car stx) (stx-cdr stx)) (values (reverse args) (stx-car stx) (stx-cdr stx))
(loop (stx-cdr stx) (cons (stx-car stx) args))))]) (loop (stx-cdr stx) (cons (stx-car stx) args))))])
(when (stx-null? result-stx) (when (stx-null? result-stx)
@ -732,7 +738,7 @@
(let-values ([(args-stx >->-stx result-stx) (let-values ([(args-stx >->-stx result-stx)
(let loop ([stx (stx-cdr (stx-car form))][args null]) (let loop ([stx (stx-cdr (stx-car form))][args null])
(if (and (identifier? (stx-car stx)) (if (and (identifier? (stx-car stx))
(module-identifier=? #'>-> (stx-car stx))) (free-identifier=? #'>-> (stx-car stx)))
(values (reverse args) (stx-car stx) (stx-cdr stx)) (values (reverse args) (stx-car stx) (stx-cdr stx))
(loop (stx-cdr stx) (cons (stx-car stx) args))))]) (loop (stx-cdr stx) (cons (stx-car stx) args))))])
(when (stx-null? result-stx) (when (stx-null? result-stx)
@ -789,7 +795,7 @@
(identifier? t) (identifier? t)
(or (and (identifier? t) (or (and (identifier? t)
(ormap (lambda (orig new) (ormap (lambda (orig new)
(and (module-identifier=? t orig) (and (free-identifier=? t orig)
new)) new))
orig-ids new-types)) orig-ids new-types))
t)] t)]
@ -821,8 +827,8 @@
[(boolean? (syntax-e val-expr)) #'bool] [(boolean? (syntax-e val-expr)) #'bool]
[(identifier? val-expr) [(identifier? val-expr)
(cond (cond
[(module-identifier=? #'false val-expr) #'bool] [(free-identifier=? #'false val-expr) #'bool]
[(module-identifier=? #'true val-expr) #'bool] [(free-identifier=? #'true val-expr) #'bool]
[else #'obj])] [else #'obj])]
[else #'obj])])) [else #'obj])]))
@ -833,22 +839,22 @@
(syntax-case target-type (-> forall) (syntax-case target-type (-> forall)
[ttid [ttid
(identifier? target-type) (identifier? target-type)
(or (module-identifier=? #'obj target-type) (or (free-identifier=? #'obj target-type)
(and (identifier? val-type) (and (identifier? val-type)
(module-identifier=? val-type target-type)) (free-identifier=? val-type target-type))
(let ([val-type (let ([val-type
(if (not val-type) (if (not val-type)
(apparent-type val-expr) (apparent-type val-expr)
val-type)]) val-type)])
(or (and (identifier? val-type) (or (and (identifier? val-type)
(or (module-identifier=? val-type target-type) (or (free-identifier=? val-type target-type)
(and (module-identifier=? #'num target-type) (and (free-identifier=? #'num target-type)
(or (module-identifier=? val-type #'int) (or (free-identifier=? val-type #'int)
(module-identifier=? val-type #'real))) (free-identifier=? val-type #'real)))
(and (module-identifier=? #'real target-type) (and (free-identifier=? #'real target-type)
(or (module-identifier=? val-type #'int))))) (or (free-identifier=? val-type #'int)))))
(if (and (identifier? val-type) (if (and (identifier? val-type)
(module-identifier=? val-type #'obj)) (free-identifier=? val-type #'obj))
#f #f
(fail-k orig-val-expr val-type target-type)))))] (fail-k orig-val-expr val-type target-type)))))]
[(-> (t-result-type t-result-protect-id) (t-arg-type t-arg-type-name t-arg-pred) ...) [(-> (t-result-type t-result-protect-id) (t-arg-type t-arg-type-name t-arg-pred) ...)
@ -871,7 +877,7 @@
(do-fail)))) (do-fail))))
t-args v-args)))] t-args v-args)))]
[_else [_else
(if (module-identifier=? val-type #'obj) (if (free-identifier=? val-type #'obj)
#f #f
(do-fail))]))] (do-fail))]))]
[(forall (poly-id ...) poly-t bindings) [(forall (poly-id ...) poly-t bindings)
@ -892,7 +898,7 @@
(do-fail)))] (do-fail)))]
[else [else
(if (and (identifier? val-type) (if (and (identifier? val-type)
(module-identifier=? val-type #'obj)) (free-identifier=? val-type #'obj))
#f #f
(do-fail))]))] (do-fail))]))]
[_else [_else
@ -979,7 +985,7 @@
v)]))] v)]))]
[(lv ([(lhs ...) expr] ...) ... body) [(lv ([(lhs ...) expr] ...) ... body)
(ormap (lambda (id) (ormap (lambda (id)
(module-identifier=? #'lv id)) (free-identifier=? #'lv id))
(list #'let-values #'letrec-values #'letrec-syntaxes+values)) (list #'let-values #'letrec-values #'letrec-syntaxes+values))
(extract-type #'body)] (extract-type #'body)]
[(begin e ... last-expr) [(begin e ... last-expr)
@ -1146,9 +1152,9 @@
[(_ #%angles a (b ...)) [(_ #%angles a (b ...))
#'(honu-type-app a b ...)] #'(honu-type-app a b ...)]
[(_ a b ...) [(_ a b ...)
(datum->syntax-object #'a (datum->syntax #'a
(cons #'a #'(b ...)) (cons #'a #'(b ...))
#'a)])) #'a)]))
(define-syntax (op-cast stx) (define-syntax (op-cast stx)
(syntax-case stx (#%parens) (syntax-case stx (#%parens)
@ -1292,7 +1298,7 @@
(define-syntax (honu-type-info stx) (raise-syntax-error #f "shouldn't appear unquoted!" stx)) (define-syntax (honu-type-info stx) (raise-syntax-error #f "shouldn't appear unquoted!" stx))
(require-for-syntax syntax/context) ;; (require-for-syntax syntax/context)
(define-syntax (honu-block stx) (define-syntax (honu-block stx)
;; A block can have mixed exprs and defns. Wrap expressions with ;; A block can have mixed exprs and defns. Wrap expressions with
;; `(define-values () ... (values))' as needed, and add a (void) ;; `(define-values () ... (values))' as needed, and add a (void)
@ -1353,7 +1359,7 @@
(begin (begin
(unless (or (not proc-id) (unless (or (not proc-id)
(not (syntax-e proc-id)) (not (syntax-e proc-id))
(module-identifier=? #'type-name #'obj)) (free-identifier=? #'type-name #'obj))
(error "no expression for type check; should have been " (error "no expression for type check; should have been "
"caught earlier")) "caught earlier"))
(reverse prev-exprs))) (reverse prev-exprs)))
@ -1362,8 +1368,8 @@
null))] null))]
[(and (stx-pair? (car exprs)) [(and (stx-pair? (car exprs))
(identifier? (stx-car (car exprs))) (identifier? (stx-car (car exprs)))
(or (module-identifier=? #'define-values (stx-car (car exprs))) (or (free-identifier=? #'define-values (stx-car (car exprs)))
(module-identifier=? #'define-syntaxes (stx-car (car exprs))))) (free-identifier=? #'define-syntaxes (stx-car (car exprs)))))
(loop (cdr exprs) (loop (cdr exprs)
(cons (car exprs) (cons (car exprs)
(append (append
@ -1417,7 +1423,7 @@
;; -------------------------------------------------------- ;; --------------------------------------------------------
;; Defining a new transformer or new type ;; Defining a new transformer or new type
(require-for-syntax syntax/define) ;; (require-for-syntax syntax/define)
(define-syntax (define-honu-syntax stx) (define-syntax (define-honu-syntax stx)
(let-values ([(id rhs) (normalize-definition stx #'lambda #f)]) (let-values ([(id rhs) (normalize-definition stx #'lambda #f)])
(with-syntax ([id id] (with-syntax ([id id]
@ -1622,7 +1628,7 @@
;; Assume anything else is ok: ;; Assume anything else is ok:
(loop #'rest (cons #'something accum))]))]) (loop #'rest (cons #'something accum))]))])
(unless (block-context? ctx) (unless (block-context? ctx)
(unless (module-identifier=? id #'function) (unless (free-identifier=? id #'function)
(raise-syntax-error #f (raise-syntax-error #f
(format (format
"named generic allowed only in a block context, not in ~a context" "named generic allowed only in a block context, not in ~a context"
@ -1632,7 +1638,7 @@
(with-syntax ([(poly-id ...) ids] (with-syntax ([(poly-id ...) ids]
[(poly-pred-id ...) (generate-temporaries ids)] [(poly-pred-id ...) (generate-temporaries ids)]
[(poly-name-id ...) (generate-temporaries ids)] [(poly-name-id ...) (generate-temporaries ids)]
[def-id (if (module-identifier=? id #'function) [def-id (if (free-identifier=? id #'function)
(or (syntax-local-infer-name id) (or (syntax-local-infer-name id)
(car (generate-temporaries '(function)))) (car (generate-temporaries '(function))))
id)] id)]
@ -1685,7 +1691,7 @@
(new-id honu-safe-use-hack) (new-id honu-safe-use-hack)
new-id)))))]) new-id)))))])
(if (module-identifier=? id #'function) (if (free-identifier=? id #'function)
;; Anonymous function: ;; Anonymous function:
;; We may have to continue parsing... ;; We may have to continue parsing...
(finish-parsing-expression "anonymous generic function" (finish-parsing-expression "anonymous generic function"
@ -2035,6 +2041,7 @@
(honu-unparsed-begin #,@rest)))])) (honu-unparsed-begin #,@rest)))]))
(define-syntax (#%dynamic-honu-module-begin stx) (define-syntax (#%dynamic-honu-module-begin stx)
;; (printf "honu raw sexp ~a\n" (syntax->datum stx))
#`(#%plain-module-begin #`(#%plain-module-begin
(honu-unparsed-begin #,@(stx-cdr stx)))) (honu-unparsed-begin #,@(stx-cdr stx))))
@ -2071,31 +2078,39 @@
string string
-> >-> -> >->
\; \;
(rename set! =) ? :
(rename honu-return return)
(rename honu-if if) ? :
(rename honu-time time)
(rename honu-class class)
(rename honu+ +) (rename honu- -) (rename honu* *)
/ (rename modulo %)
< > <= >= (rename equal? ==) !=
&& \|\| && \|\|
(rename string->number stringToNumber) /
(rename number->string numberToString) < > <= >=
cons list !=
(rename car first) cons list
(rename cdr rest) true false
(rename null empty)
(rename null? isEmpty)
(rename pair? isCons)
true false
display write newline display write newline
#%datum #%datum
#%top #%top
#%parens #%brackets #%braces #%angles #%parens #%brackets #%braces #%angles
#%prefix #%postfix #%prefix #%postfix
(rename #%dynamic-honu-module-begin #%module-begin) define-honu-syntax
(rename honu-#%app #%app)
define-honu-syntax (rename-out (set! =)
(rename honu-provide provide) (honu-return return)
(rename honu-require require))) (honu-if if)
(honu-time time)
(honu-class class)
(honu+ +)
(honu- -)
(honu* *)
(modulo %)
(equal? ==)
(string->number stringToNumber)
(number->string numberToString)
(car first)
(cdr rest)
(null empty)
(null? isEmpty)
(pair? isCons)
(#%dynamic-honu-module-begin #%module-begin)
(honu-#%app #%app)
(honu-provide provide)
(honu-require require)))