* exported syntax-dispatch

* renamed:
   src/libsyntax.ss => src/ikarus.syntax.ss
This commit is contained in:
Abdulaziz Ghuloum 2007-05-05 22:05:34 -04:00
parent 4814f48573
commit 20e7940059
4 changed files with 40 additions and 34 deletions

Binary file not shown.

View File

@ -2554,7 +2554,7 @@
s)) s))
(define (check? x) (define (check? x)
(cond (cond
[(primref? x) #t] ;;;; PRIMREF CHECK [(primref? x) #f] ;;;; PRIMREF CHECK
[(closure? x) #f] [(closure? x) #f]
[else #t])) [else #t]))
(define (do-new-frame label op rand* si r (define (do-new-frame label op rand* si r

View File

@ -1,7 +1,14 @@
(library (ikarus syntax) (library (ikarus syntax)
(export) (export identifier? syntax-dispatch
(import (scheme)) generate-temporaries free-identifier=? syntax-error
boot-library-expand eval-top-level)
(import
(rename (except (ikarus) boot-library-expand syntax-error eval-top-level)
(free-identifier=? sys:free-identifier=?)
(identifier? sys:identifier?)
(generate-temporaries sys:generate-temporaries)))
(define who 'expander) (define who 'expander)
(define-syntax no-source (define-syntax no-source
(lambda (x) #f)) (lambda (x) #f))
@ -348,15 +355,15 @@
(lambda (ctx) (lambda (ctx)
(define dots? (define dots?
(lambda (x) (lambda (x)
(and (identifier? x) (and (sys:identifier? x)
(free-identifier=? x #'(... ...))))) (sys:free-identifier=? x #'(... ...)))))
(define free-identifier-member? (define free-identifier-member?
(lambda (x ls) (lambda (x ls)
(and (ormap (lambda (y) (free-identifier=? x y)) ls) #t))) (and (ormap (lambda (y) (sys:free-identifier=? x y)) ls) #t)))
(define f (define f
(lambda (ctx lits) (lambda (ctx lits)
(syntax-case ctx () (syntax-case ctx ()
[id (identifier? #'id) [id (sys:identifier? #'id)
(if (free-identifier-member? #'id lits) (if (free-identifier-member? #'id lits)
#'(lambda (x) (and (id? x) (free-id=? x (scheme-stx 'id)))) #'(lambda (x) (and (id? x) (free-id=? x (scheme-stx 'id))))
#'(lambda (x) #t))] #'(lambda (x) #t))]
@ -396,15 +403,15 @@
(lambda (ctx) (lambda (ctx)
(define free-identifier-member? (define free-identifier-member?
(lambda (x ls) (lambda (x ls)
(and (ormap (lambda (y) (free-identifier=? x y)) ls) #t))) (and (ormap (lambda (y) (sys:free-identifier=? x y)) ls) #t)))
(define dots? (define dots?
(lambda (x) (lambda (x)
(and (identifier? x) (and (sys:identifier? x)
(free-identifier=? x #'(... ...))))) (sys:free-identifier=? x #'(... ...)))))
(define f (define f
(lambda (stx lits) (lambda (stx lits)
(syntax-case stx () (syntax-case stx ()
[id (identifier? #'id) [id (sys:identifier? #'id)
(if (free-identifier-member? #'id lits) (if (free-identifier-member? #'id lits)
(values '() #'(lambda (x) (dont-call-me))) (values '() #'(lambda (x) (dont-call-me)))
(values (list #'id) #'(lambda (x) x)))] (values (list #'id) #'(lambda (x) x)))]
@ -417,7 +424,7 @@
(values vars (values vars
(with-syntax ([(vars ...) vars] (with-syntax ([(vars ...) vars]
[ext extractor] [ext extractor]
[(t* ...) (generate-temporaries vars)]) [(t* ...) (sys:generate-temporaries vars)])
#'(lambda (x) #'(lambda (x)
(let f ([x x] [vars '()] ...) (let f ([x x] [vars '()] ...)
(cond (cond
@ -437,7 +444,7 @@
[(null? lvars) [(null? lvars)
(values pvars (values pvars
(with-syntax ([(pvars ...) pvars] (with-syntax ([(pvars ...) pvars]
[(t* ...) (generate-temporaries pvars)] [(t* ...) (sys:generate-temporaries pvars)]
[pext pext]) [pext pext])
#'(lambda (x) #'(lambda (x)
(let loop ([x x] [pvars '()] ...) (let loop ([x x] [pvars '()] ...)
@ -458,7 +465,7 @@
[else [else
(values (append pvars lvars) (values (append pvars lvars)
(with-syntax ([(pvars ...) pvars] (with-syntax ([(pvars ...) pvars]
[(t* ...) (generate-temporaries pvars)] [(t* ...) (sys:generate-temporaries pvars)]
[(lvars ...) lvars] [(lvars ...) lvars]
[lext lext] [lext lext]
[pext pext]) [pext pext])
@ -1366,13 +1373,13 @@
(gen-ref src (car var.lev) (cdr var.lev) maps)))) (gen-ref src (car var.lev) (cdr var.lev) maps))))
(values (list 'ref var) maps)) (values (list 'ref var) maps))
(if (ellipsis? e) (if (ellipsis? e)
(syntax-error src "1misplaced ellipsis in syntax form") (stx-error src "1misplaced ellipsis in syntax form")
(begin (begin
(values (list 'quote e) maps)))))) (values (list 'quote e) maps))))))
(match2 e (lambda (dots e) (ellipsis? dots)) (match2 e (lambda (dots e) (ellipsis? dots))
(lambda (dots e) (lambda (dots e)
(if vec? (if vec?
(syntax-error src "2misplaced ellipsis in syntax form") (stx-error src "2misplaced ellipsis in syntax form")
(gen-syntax src e r maps (lambda (x) #f) #f))) (gen-syntax src e r maps (lambda (x) #f) #f)))
(lambda () (lambda ()
(cond (cond
@ -1386,7 +1393,7 @@
(gen-syntax src (syntax-car e) r (gen-syntax src (syntax-car e) r
(cons '() maps) ellipsis? #f))) (cons '() maps) ellipsis? #f)))
(if (null? (car maps)) (if (null? (car maps))
(syntax-error src (stx-error src
"extra ellipsis in syntax form") "extra ellipsis in syntax form")
(values (gen-map x (car maps)) (cdr maps))))))) (values (gen-map x (car maps)) (cdr maps)))))))
(cond (cond
@ -1397,7 +1404,7 @@
(lambda (maps) (lambda (maps)
(let-values (((x maps) (k (cons '() maps)))) (let-values (((x maps) (k (cons '() maps))))
(if (null? (car maps)) (if (null? (car maps))
(syntax-error src "extra ellipsis in syntax form") (stx-error src "extra ellipsis in syntax form")
(values (gen-mappend x (car maps)) (cdr maps))))))) (values (gen-mappend x (car maps)) (cdr maps)))))))
(else (else
(let-values (((y maps) (let-values (((y maps)
@ -1425,7 +1432,7 @@
(if (= level 0) (if (= level 0)
(values var maps) (values var maps)
(if (null? maps) (if (null? maps)
(syntax-error src "missing ellipsis in syntax form") (stx-error src "missing ellipsis in syntax form")
(let-values (((outer-var outer-maps) (let-values (((outer-var outer-maps)
(gen-ref src var (- level 1) (cdr maps)))) (gen-ref src var (- level 1) (cdr maps))))
(cond (cond
@ -1509,7 +1516,7 @@
(lambda (_ x) (lambda (_ x)
(let-values (((e maps) (gen-syntax e x r '() ellipsis? #f))) (let-values (((e maps) (gen-syntax e x r '() ellipsis? #f)))
(regen e))) (regen e)))
(lambda () (syntax-error e)))))) (lambda () (stx-error e))))))
(define core-macro-transformer (define core-macro-transformer
(lambda (name) (lambda (name)
(case name (case name
@ -1578,7 +1585,7 @@
(let* ([loc value] (let* ([loc value]
[lib (imported-loc->library loc)]) [lib (imported-loc->library loc)])
(unless lib (unless lib
(syntax-error e "BUG: cannot find defining library")) (stx-error e "BUG: cannot find defining library"))
((run-collector) lib) ((run-collector) lib)
(build-global-reference no-source loc))] (build-global-reference no-source loc))]
[(core-prim) [(core-prim)
@ -1732,7 +1739,7 @@
[(define-syntax) [(define-syntax)
(let-values ([(id rhs) (parse-define-syntax e)]) (let-values ([(id rhs) (parse-define-syntax e)])
(when (bound-id-member? id kwd*) (when (bound-id-member? id kwd*)
(syntax-error id "undefined identifier")) (stx-error id "undefined identifier"))
(let ([lab (gen-label id)]) (let ([lab (gen-label id)])
(let ([expanded-rhs (chi-expr rhs mr mr)]) (let ([expanded-rhs (chi-expr rhs mr mr)])
(extend-rib! rib id lab) (extend-rib! rib id lab)
@ -1824,7 +1831,7 @@
[(define-syntax) [(define-syntax)
(let-values ([(id rhs) (parse-define-syntax e)]) (let-values ([(id rhs) (parse-define-syntax e)])
(when (bound-id-member? id kwd*) (when (bound-id-member? id kwd*)
(syntax-error id "undefined identifier")) (stx-error id "undefined identifier"))
(let ([lab (gen-label id)]) (let ([lab (gen-label id)])
(let ([expanded-rhs (chi-expr rhs mr mr)]) (let ([expanded-rhs (chi-expr rhs mr mr)])
(extend-rib! rib id lab) (extend-rib! rib id lab)
@ -1876,7 +1883,7 @@
[(define-syntax) [(define-syntax)
(let-values ([(id rhs) (parse-define-syntax e)]) (let-values ([(id rhs) (parse-define-syntax e)])
(when (bound-id-member? id kwd*) (when (bound-id-member? id kwd*)
(syntax-error id "undefined identifier")) (stx-error id "undefined identifier"))
(let ([lab (gen-label id)]) (let ([lab (gen-label id)])
(let ([expanded-rhs (chi-expr rhs mr mr)]) (let ([expanded-rhs (chi-expr rhs mr mr)])
(extend-rib! rib id lab) (extend-rib! rib id lab)
@ -2112,7 +2119,7 @@
void ;;; FIXME void ;;; FIXME
(lambda () (eval-core invoke-code))) (lambda () (eval-core invoke-code)))
(values invoke-code export-subst export-env)))) (values invoke-code export-subst export-env))))
(define (boot-library-expander x) (define (boot-library-expand x)
(let-values ([(invoke-code export-subst export-env) (let-values ([(invoke-code export-subst export-env)
(library-expander x)]) (library-expander x)])
(values invoke-code export-subst export-env))) (values invoke-code export-subst export-env)))
@ -2138,29 +2145,28 @@
(cons (cons (car ext*) label) subst) (cons (cons (car ext*) label) subst)
(cons (cons label (cons 'global (binding-value b))) env))] (cons (cons label (cons 'global (binding-value b))) env))]
[else (error #f "cannot export ~s of type ~s" sym type)]))]))) [else (error #f "cannot export ~s of type ~s" sym type)]))])))
(primitive-set! 'identifier? id?) ; (primitive-set! 'identifier? id?)
(primitive-set! 'generate-temporaries (define generate-temporaries
(lambda (ls) (lambda (ls)
(unless (list? ls) (unless (list? ls)
(error 'generate-temporaries "~s is not a list")) (error 'generate-temporaries "~s is not a list"))
(map (lambda (x) (stx (gensym 't) top-mark* '())) ls))) (map (lambda (x) (stx (gensym 't) top-mark* '())) ls)))
(primitive-set! 'free-identifier=? (define free-identifier=?
(lambda (x y) (lambda (x y)
(if (id? x) (if (id? x)
(if (id? y) (if (id? y)
(free-id=? x y) (free-id=? x y)
(error 'free-identifier=? "~s is not an identifier" y)) (error 'free-identifier=? "~s is not an identifier" y))
(error 'free-identifier=? "~s is not an identifier" x)))) (error 'free-identifier=? "~s is not an identifier" x))))
(primitive-set! 'syntax-error (define syntax-error
(lambda (x . args) (lambda (x . args)
(unless (andmap string? args) (unless (andmap string? args)
(error 'syntax-error "invalid argument ~s" args)) (error 'syntax-error "invalid argument ~s" args))
(error #f "~a: ~s" (error #f "~a: ~s"
(apply string-append args) (apply string-append args)
(strip x '())))) (strip x '()))))
(primitive-set! 'syntax-dispatch syntax-dispatch) (define identifier? (lambda (x) (id? x)))
(primitive-set! 'boot-library-expand boot-library-expander) (define eval-top-level
(primitive-set! 'eval-top-level
(lambda (x) (lambda (x)
(unless (pair? x) (unless (pair? x)
(error #f "invalid expression at top-level ~s" x)) (error #f "invalid expression at top-level ~s" x))

View File

@ -57,7 +57,7 @@
"ikarus.intel-assembler.ss" "ikarus.intel-assembler.ss"
"ikarus.fasl.ss" "ikarus.fasl.ss"
"ikarus.compiler.ss" "ikarus.compiler.ss"
"libsyntax.ss" "ikarus.syntax.ss"
"libpp.ss" "libpp.ss"
"libcafe.ss" "libcafe.ss"
"libposix.ss" "libposix.ss"
@ -538,7 +538,7 @@
[do-vararg-overflow s] [do-vararg-overflow s]
[collect s] [collect s]
[do-stack-overflow s] [do-stack-overflow s]
[syntax-dispatch s]
)) ))