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

towards consistency with javascript

Browse Source 
svn: r2869
This commit is contained in:
Matthew Flatt 2006-05-06 15:55:27 +00:00
parent 12f990e663
commit 75e66c2b10
2 changed files with 133 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -319,42 +319,52 @@
(let loop ([args-stx orig-args-stx] (let loop ([args-stx orig-args-stx]
[where "at start of argument sequence"] [where "at start of argument sequence"]
[where-stx orig-args-stx]) [where-stx orig-args-stx])
(let ([trans (get-transformer args-stx)]) (let-values ([(type rest-stx) (if (syntax-case args-stx (\,)
(let-values ([(type rest-stx) (if trans [(id \, . rest)
(trans args-stx type-context) (identifier? #'id)
(values #f #f))]) #t]
(unless (honu-type? type) [(id)
(raise-syntax-error (identifier? #'id)
'|procedure declaration| #t]
(format "expected a type ~a" where) [_else #f])
where-stx)) (values (make-h-type #'val #'(begin) #'(lambda (x) (values #t x)))
(syntax-case rest-stx () args-stx)
[(id) (let ([trans (get-transformer args-stx)])
(identifier? #'id) (if trans
(parse-one-argument proc-id type #'id (trans args-stx type-context)
(lambda () null))] (values #f #f))))])
[(id comma . rest) (unless (honu-type? type)
(and (identifier? #'id) (raise-syntax-error
(identifier? #'comma) '|procedure declaration|
(module-identifier=? #'comma #'\,)) (format "expected a type ~a" where)
(parse-one-argument proc-id type #'id where-stx))
(lambda () (syntax-case rest-stx ()
(loop #'rest [(id)
"after comma" (identifier? #'id)
#'comma)))] (parse-one-argument proc-id type #'id
[(id something . rest) (lambda () null))]
(identifier? #'id) [(id comma . rest)
(raise-syntax-error (and (identifier? #'id)
'procedure\ declaration (identifier? #'comma)
"expected a comma after identifier name" (module-identifier=? #'comma #'\,))
#'something)] (parse-one-argument proc-id type #'id
[_else (lambda ()
(raise-syntax-error (loop #'rest
'procedure\ declaration "after comma"
"expected an argument identifier" #'comma)))]
(car rest-stx))])))))) [(id something . rest)
(identifier? #'id)
(raise-syntax-error
'procedure\ declaration
"expected a comma after identifier name"
#'something)]
[_else
(raise-syntax-error
'procedure\ declaration
"expected an argument identifier"
(car rest-stx))])))))
(define (make-honu-type pred-id mk-pred-def) (define (make-honu-type pred-id mk-pred-def only-mode)
(make-honu-trans (make-honu-trans
(lambda (orig-stx ctx) (lambda (orig-stx ctx)
(let* ([pred-id (or pred-id (let* ([pred-id (or pred-id
@ -381,63 +391,80 @@
(if (and (identifier? (stx-car #'rest)) (if (and (identifier? (stx-car #'rest))
(module-identifier=? #'set! (stx-car #'rest))) (module-identifier=? #'set! (stx-car #'rest)))
;; -- Non-procedure declaration ;; -- Non-procedure declaration
(let-values ([(val-stxs after-expr) (extract-until (stx-cdr #'rest) (if (eq? 'function only-mode)
(list #'\; #'\,))])
(unless val-stxs
(raise-syntax-error (raise-syntax-error
'declaration 'declaration
"missing semicolon or comma after initializing assignment" "expected parentheses after name for function definition"
(stx-car #'rest))) (stx-car #'rest))
(when (null? val-stxs) (let-values ([(val-stxs after-expr) (extract-until (stx-cdr #'rest)
(raise-syntax-error (list #'\; #'\,))])
'declaration (unless val-stxs
"missing expression initializing assignment" (raise-syntax-error
(stx-car #'rest))) 'declaration
(let ([def #`(define-typed id #f type-name pred-id "missing semicolon or comma after initializing assignment"
(check-expr #f 'id type-name pred-id (stx-car #'rest)))
(honu-unparsed-expr #,@val-stxs)))]) (when (null? val-stxs)
(if (module-identifier=? #'\; (stx-car after-expr)) (raise-syntax-error
(values #`(begin #,pred-def #,def) (stx-cdr after-expr)) 'declaration
(let-values ([(defs remainder kind) (loop (stx-cdr after-expr) (stx-car after-expr) "comma" #f)]) "missing expression initializing assignment"
(values #`(begin #,pred-def #,def #,defs) remainder))))) (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)))])
(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 ;; -- Procedure declaration
(syntax-case #'rest (#%parens \;) (if (eq? 'var only-mode)
[((#%parens . prest) (#%braces . body) . rest) (raise-syntax-error
parens-ok? 'declaration
(let ([args (parse-arguments #'prest #'id)]) "expected = after name for variable"
(with-syntax ([((arg arg-type arg-pred-def arg-pred-id) ...) args] (stx-car #'rest))
[(temp-id ...) (generate-temporaries (map car args))]) (syntax-case #'rest (#%parens \;)
(values #`(begin [((#%parens . prest) (#%braces . body) . rest)
#,pred-def parens-ok?
arg-pred-def ... (let ([args (parse-arguments #'prest #'id)])
(define-typed-procedure id (with-syntax ([((arg arg-type arg-pred-def arg-pred-id) ...) args]
((arg arg-type arg-pred-id) ...) [(temp-id ...) (generate-temporaries (map car args))])
(lambda (temp-id ...) (values #`(begin
(define-typed arg id arg-type arg-pred-id temp-id) ... #,pred-def
(honu-unparsed-block id type-name pred-id #t . body)))) arg-pred-def ...
#'rest)))] (define-typed-procedure id
;; --- Error handling --- ((arg arg-type arg-pred-id) ...)
[((#%parens . prest) . bad-rest) (lambda (temp-id ...)
parens-ok? (define-typed arg id arg-type arg-pred-id temp-id) ...
(begin (honu-unparsed-block id type-name pred-id #t . body))))
(parse-arguments #'prest #'id) #'rest)))]
(raise-syntax-error ;; --- Error handling ---
'|procedure declaration| [((#%parens . prest) . bad-rest)
"braces for function body after parenthesized arguments" parens-ok?
(stx-car #'rest) (begin
#'id))] (parse-arguments #'prest #'id)
[_else (raise-syntax-error
(raise-syntax-error '|procedure declaration|
'|declaration| "braces for function body after parenthesized arguments"
(if parens-ok? (stx-car #'rest)
"expected either = (for variable intialization) or parens (for function arguments)" #'id))]
"expected = (for variable initialization)") [_else
#'id)])))] (raise-syntax-error
'|declaration|
(if parens-ok?
"expected either = (for variable intialization) or parens (for function arguments)"
"expected = (for variable initialization)")
#'id)]))))]
[_else [_else
(raise-syntax-error #f (raise-syntax-error #f
(format "expected a identifier after ~a" after-what) (format "expected a identifier after ~a" after-what)
after after
#'id)])))] #'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) [(type-context? ctx)
(values (make-h-type (stx-car orig-stx) pred-def pred-id) (stx-cdr orig-stx))] (values (make-h-type (stx-car orig-stx) pred-def pred-id) (stx-cdr orig-stx))]
[(expression-context? ctx) [(expression-context? ctx)
@ -505,7 +532,7 @@
(and (identifier? target-type) (and (identifier? target-type)
(identifier? val-type) (identifier? val-type)
(or (module-identifier=? val-type target-type) (or (module-identifier=? val-type target-type)
(module-identifier=? #'obj target-type) (module-identifier=? #'val target-type)
(and (number? (syntax-e val-expr)) (and (number? (syntax-e val-expr))
(module-identifier=? #'num target-type)) (module-identifier=? #'num target-type))
(and (integer? (syntax-e val-expr)) (and (integer? (syntax-e val-expr))
@ -552,8 +579,8 @@
#'val] #'val]
[_else [_else
;; Even without a type for v, we might see a literal, ;; Even without a type for v, we might see a literal,
;; or maybe the declaration is simply obj ;; or maybe the declaration is simply val
(if (compatible-type? v #'obj #'type-name) (if (compatible-type? v #'val #'type-name)
;; No run-time check: ;; No run-time check:
#'val #'val
;; Run-time check: ;; Run-time check:
@ -717,13 +744,13 @@
(define pred-id (let ([pred pred-expr]) (define pred-id (let ([pred pred-expr])
(lambda (v) (lambda (v)
(values (pred v) v)))) (values (pred v) v))))
(define-syntax id (make-honu-type #'pred-id #f))))])) (define-syntax id (make-honu-type #'pred-id #f #f))))]))
(define-syntax (define-type-constructor stx) (define-syntax (define-type-constructor stx)
(syntax-case stx () (syntax-case stx ()
[(_ id generator-expr) [(_ id generator-expr)
(identifier? #'id) (identifier? #'id)
#'(define-syntax id (make-honu-type #f generator-expr))])) #'(define-syntax id (make-honu-type #f generator-expr #f))]))
;; ---------------------------------------- ;; ----------------------------------------
;; Pre-defined types and forms ;; Pre-defined types and forms
@ -737,6 +764,9 @@
(define-type obj (lambda (x) #t)) (define-type obj (lambda (x) #t))
(define-type string-type string?) (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-type-constructor -> make-proc-predicate) (define-type-constructor -> make-proc-predicate)
(define-for-syntax parse-comma-separated (define-for-syntax parse-comma-separated
@ -986,8 +1016,7 @@
(honu-unparsed-begin #,@rest)))])) (honu-unparsed-begin #,@rest)))]))
(define-syntax (#%dynamic-honu-module-begin stx) (define-syntax (#%dynamic-honu-module-begin stx)
#`(begin #`(#%plain-module-begin
#,(syntax-local-introduce #'(require (lib "dynamic.ss" "honu-module")))
(honu-unparsed-begin #,@(stx-cdr stx)))) (honu-unparsed-begin #,@(stx-cdr stx))))
(define-syntax (\; stx) (raise-syntax-error '\; "out of context" stx)) (define-syntax (\; stx) (raise-syntax-error '\; "out of context" stx))
@ -995,7 +1024,9 @@
(define true #t) (define true #t)
(define false #f) (define false #f)
(provide int real obj (rename string-type string) -> (provide int real obj
function var
(rename string-type string) ->
\; \;
(rename set! =) (rename set! =)
(rename honu-return return) (rename honu-return return)
@ -1008,7 +1039,7 @@
#%datum #%datum
#%top #%top
#%parens #%parens
#%dynamic-honu-module-begin (rename #%dynamic-honu-module-begin #%module-begin)
define-honu-syntax define-honu-syntax
(rename honu-provide provide) (rename honu-provide provide)
(rename honu-require require))) (rename honu-require require)))

26
collects/honu-module/honu-module.ss
View File

@ -1,23 +1,11 @@
(module honu-module mzscheme (module honu-module mzscheme
(require (only "dynamic.ss" #%dynamic-honu-module-begin)) (define-syntax m
(syntax-rules ()
[(_ require provide)
(begin
(require "dynamic.ss")
(provide (all-from "dynamic.ss")))]))
(m require provide))
(define-syntax (honu-module-begin stx)
(syntax-case stx (dynamic)
[(_ dynamic . body)
#`(#%module-begin
(#%dynamic-honu-module-begin
. body))]
[(_ other . body)
(identifier? #'other)
(raise-syntax-error
#f
"unknown Honu dialect"
#'other)]
[else
(raise-syntax-error
#f
"expected a Honu dialect name before module body"
stx)]))
(provide (rename honu-module-begin #%module-begin)))