You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
490 lines
19 KiB
Scheme
490 lines
19 KiB
Scheme
27 years ago
|
;; parser.ss
|
||
|
|
;;
|
||
|
|
;; Takes a zodiac:sexp, and an env: sym -> zodiac:bound,
|
||
|
|
;; and produces a zodiac:ast and a list of unbound zodiac:bounds
|
||
|
|
;; Only handles R4RS primitive syntax
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
(define keywords
|
||
|
|
'(begin cond delay if set! set!-values quote begin lambda case-lambda
|
||
|
|
poly
|
||
|
|
let-values letrec*-values
|
||
|
|
unit compound-unit invoke-unit
|
||
|
|
: type:-quote
|
||
|
|
cache-exp-quote cache-inv-quote
|
||
|
|
struct typed-structure const-typed-structure
|
||
|
|
))
|
||
|
|
|
||
|
|
(define define-keywords
|
||
|
|
'(define-values
|
||
|
|
define-type
|
||
|
|
define-constructor
|
||
|
|
))
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define (top-level-parse-defs defs)
|
||
|
|
(set! unbound-env '())
|
||
|
|
(let-values ([(defs nuenv) (parse-defs defs empty-env)])
|
||
|
|
(values defs (map cdr unbound-env))))
|
||
|
|
|
||
|
|
(define (top-level-parse-exp exp)
|
||
|
|
(set! unbound-env '())
|
||
|
|
(let ([ast (parse exp empty-env)])
|
||
|
|
(values ast (map cdr unbound-env))))
|
||
|
|
|
||
|
|
(define unbound-env '())
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define syntax-error
|
||
|
|
(case-lambda
|
||
|
|
[(exp) (syntax-error exp "Bad syntax")]
|
||
|
|
[(exp s)
|
||
|
|
(mrspidey:error
|
||
|
|
(format "File ~s, Line ~s: ~a ~s"
|
||
|
|
(file-name-from-path
|
||
|
|
(zodiac:location-file (zodiac:zodiac-start exp)))
|
||
|
|
(zodiac:location-line (zodiac:zodiac-start exp))
|
||
|
|
s (zodiac:stripper exp)))]))
|
||
|
|
|
||
|
|
(define syntax-error-no-exp
|
||
|
|
(case-lambda
|
||
|
|
[(exp) (syntax-error-no-exp exp "Bad syntax")]
|
||
|
|
[(exp s)
|
||
|
|
(mrspidey:error
|
||
|
|
(format "File ~s, Line ~s: ~as"
|
||
|
|
(file-name-from-path
|
||
|
|
(zodiac:location-file (zodiac:zodiac-start exp)))
|
||
|
|
(zodiac:location-line (zodiac:zodiac-start exp))
|
||
|
|
s))]))
|
||
|
|
|
||
|
|
(define assert-syn
|
||
|
|
(case-lambda
|
||
|
|
[(exp x) (assert-syn exp x "Bad syntax")]
|
||
|
|
[(exp x s) (unless x (syntax-error exp s))]))
|
||
|
|
|
||
|
|
(define parse-body
|
||
|
|
(lambda (o s f body env)
|
||
|
|
(assert (list? body))
|
||
|
|
(recur loop ([rest body])
|
||
|
|
(match rest
|
||
|
|
[(exp) (parse exp env)]
|
||
|
|
[(exp . rest)
|
||
|
|
(zodiac:make-begin-form o s f (box 0)
|
||
|
|
(parse exp env)
|
||
|
|
(loop rest))]))))
|
||
|
|
|
||
|
|
(define do-bindings
|
||
|
|
(lambda (env syms)
|
||
|
|
(assert (list? syms))
|
||
|
|
(let* ([bindings
|
||
|
|
(map
|
||
|
|
(match-lambda
|
||
|
|
[($ zodiac:symbol o s f sym)
|
||
|
|
(let ([bound (zodiac:make-bound o s f (box 0) sym sym)])
|
||
|
|
(cons sym bound))]
|
||
|
|
[exp (syntax-error exp "Bad binding syntax")])
|
||
|
|
syms)]
|
||
|
|
[syms (map car bindings)]
|
||
|
|
[bounds (map cdr bindings)]
|
||
|
|
[nuenv (extend-env* env syms bounds)])
|
||
|
|
(values bounds nuenv))))
|
||
|
|
|
||
|
|
(define do-bindingss
|
||
|
|
(lambda (env symss)
|
||
|
|
(recur loop ([env env][symss symss][boundss '()])
|
||
|
|
(if (null? symss)
|
||
|
|
(values (reverse boundss) env)
|
||
|
|
(let-values
|
||
|
|
([(bounds env) (do-bindings env (car symss))])
|
||
|
|
(loop env (cdr symss) (cons bounds boundss)))))))
|
||
|
|
|
||
|
|
(define parse
|
||
|
|
;; parses an expression
|
||
|
|
(lambda (exp env)
|
||
|
|
(pretty-debug-front `(parse ,(zodiac:stripper exp)))
|
||
|
|
(letrec ([lookup-sym
|
||
|
|
(lambda (sym s f env)
|
||
|
|
(let ([bound
|
||
|
|
(or (lookup-or-#f env sym)
|
||
|
|
(lookup-or-#f unbound-env sym)
|
||
|
|
;; Add to unbound-env
|
||
|
|
(let ([n (zodiac:my-create-bound sym s f)])
|
||
|
|
(set! unbound-env (cons (cons sym n) unbound-env))
|
||
|
|
n))])
|
||
|
|
;;(set-bound-refs! bound (add1 (bound-refs bound)))
|
||
|
|
bound))]
|
||
|
|
[parse-sym-env
|
||
|
|
(lambda (env)
|
||
|
|
(match-lambda
|
||
|
|
[($ zodiac:symbol o s f sym)
|
||
|
|
;;(printf "ref sym ~s~n" sym)
|
||
|
|
(zodiac:make-lexical-varref o s f (box 0)
|
||
|
|
sym (lookup-sym sym s f env))]
|
||
|
|
[exp (syntax-error exp "Expected a variable:")]))]
|
||
|
|
[parse-sym (parse-sym-env env)]
|
||
|
|
[call-void
|
||
|
|
(lambda (o s f)
|
||
|
|
(zodiac:make-app
|
||
|
|
o s f (box 0)
|
||
|
|
(zodiac:make-lexical-varref o s f (box 0)
|
||
|
|
'void (lookup-sym 'void s f '()))
|
||
|
|
'()))]
|
||
|
|
[parse-exps
|
||
|
|
(lambda (exps env)
|
||
|
|
(map (lambda (e) (parse e env)) exps))]
|
||
|
|
[handle-args
|
||
|
|
(lambda (args env)
|
||
|
|
(match args
|
||
|
|
[($ zodiac:list _ _ _ args) (do-bindings env args)]
|
||
|
|
[($ zodiac:symbol)
|
||
|
|
(let-values
|
||
|
|
([(bounds nuenv) (do-bindings env (list args))])
|
||
|
|
(values (car bounds) nuenv))]
|
||
|
|
[($ zodiac:improper-list _ _ _ l)
|
||
|
|
(recur loop ([args '()][l l])
|
||
|
|
(match l
|
||
|
|
[(arg)
|
||
|
|
(let-values
|
||
|
|
([(bounds nuenv)
|
||
|
|
(do-bindings env (cons arg args))])
|
||
|
|
(values (append (reverse (cdr bounds)) (car bounds))
|
||
|
|
nuenv))]
|
||
|
|
[(arg . rest) (loop (cons arg args) rest)]))]))])
|
||
|
|
|
||
|
|
(pretty-debug-front `(parse ,(zodiac:stripper exp)))
|
||
|
|
(match exp
|
||
|
|
;; Identifiers
|
||
|
|
[($ zodiac:symbol o s f sym) (parse-sym exp)]
|
||
|
|
|
||
|
|
;; Scalars, vectors
|
||
|
|
[(or ($ zodiac:scalar o s f) ($ zodiac:vector o s f))
|
||
|
|
(zodiac:make-quote-form o s f (box 0) exp)]
|
||
|
|
|
||
|
|
;; Special forms
|
||
|
|
[($ zodiac:list o s f
|
||
|
|
(and l (($ zodiac:symbol _ _ _ sym) . body)))
|
||
|
|
(=> fail)
|
||
|
|
(let ([sym (strip-hash-percent sym)])
|
||
|
|
(cond
|
||
|
|
[(memq sym keywords)
|
||
|
|
(match (cons sym body)
|
||
|
|
[('cond)
|
||
|
|
(call-void o s f)]
|
||
|
|
[('delay exp)
|
||
|
|
(zodiac:make-delay-form o s f (box 0) (parse exp env))]
|
||
|
|
[('if test then else)
|
||
|
|
(zodiac:make-if-form o s f (box 0)
|
||
|
|
(parse test env)
|
||
|
|
(parse then env)
|
||
|
|
(parse else env))]
|
||
|
|
[('if test then)
|
||
|
|
(zodiac:make-if-form o s f (box 0)
|
||
|
|
(parse test env)
|
||
|
|
(parse then env)
|
||
|
|
(call-void o s f))]
|
||
|
|
[(or
|
||
|
|
('set! var exp)
|
||
|
|
('set!-values ($ zodiac:list _ _ _ (var)) exp))
|
||
|
|
|
||
|
|
(let ([var (parse-sym var)])
|
||
|
|
(when (zodiac:lexical-varref? var)
|
||
|
|
(zodiac:set-bound-mutated!
|
||
|
|
(zodiac:lexical-varref-binding var)
|
||
|
|
#t))
|
||
|
|
(zodiac:make-set!-form o s f (box 0)
|
||
|
|
var (parse exp env)))]
|
||
|
|
[('quote sexp)
|
||
|
|
(assert-syn exp (= (length body) 1))
|
||
|
|
(zodiac:make-quote-form o s f (box 0) sexp)]
|
||
|
|
[('begin . exps)
|
||
|
|
(recur loop ([exps exps])
|
||
|
|
(match exps
|
||
|
|
[() (call-void o s f)]
|
||
|
|
[(exp) (parse exp env)]
|
||
|
|
[(exp . exps)
|
||
|
|
(zodiac:make-begin-form o s f (box 0)
|
||
|
|
(parse exp env)
|
||
|
|
(loop exps))]))]
|
||
|
|
[('lambda args . bodies)
|
||
|
|
(let-values
|
||
|
|
([(bounds nuenv) (handle-args args env)])
|
||
|
|
(zodiac:make-lambda-form o s f (box 0)
|
||
|
|
bounds
|
||
|
|
(parse-body o s f bodies nuenv)))]
|
||
|
|
[('case-lambda . cases)
|
||
|
|
(zodiac:make-case-lambda-form
|
||
|
|
o s f (box 0)
|
||
|
|
(mapLR
|
||
|
|
(match-lambda
|
||
|
|
[($ zodiac:list _ _ _ (args . body))
|
||
|
|
(let-values
|
||
|
|
([(bounds nuenv) (handle-args args env)])
|
||
|
|
(cons bounds (parse-body o s f body nuenv)))]
|
||
|
|
[_ (syntax-error-no-exp exp "Bad case lambda")])
|
||
|
|
cases))]
|
||
|
|
|
||
|
|
[('let-values
|
||
|
|
($ zodiac:list _ _ _
|
||
|
|
(($ zodiac:list _ _ _
|
||
|
|
(($ zodiac:list _ _ _ varss)
|
||
|
|
exps))
|
||
|
|
...))
|
||
|
|
. bodies)
|
||
|
|
(let-values
|
||
|
|
([(boundss nuenv) (do-bindingss env varss)])
|
||
|
|
(zodiac:make-let-values-form
|
||
|
|
o s f (box 0)
|
||
|
|
boundss
|
||
|
|
(parse-exps exps env)
|
||
|
|
(parse-body o s f bodies nuenv)))]
|
||
|
|
|
||
|
|
[('letrec*-values
|
||
|
|
($ zodiac:list _ _ _
|
||
|
|
(($ zodiac:list _ _ _
|
||
|
|
(($ zodiac:list _ _ _ varss)
|
||
|
|
exps))
|
||
|
|
...))
|
||
|
|
. bodies)
|
||
|
|
(let-values
|
||
|
|
([(boundss nuenv) (do-bindingss env varss)])
|
||
|
|
(for-each
|
||
|
|
(lambda (name) (zodiac:set-bound-mutated! name #t))
|
||
|
|
(apply append boundss))
|
||
|
|
(zodiac:make-letrec-values-form
|
||
|
|
o s f (box 0)
|
||
|
|
boundss
|
||
|
|
(parse-exps exps nuenv)
|
||
|
|
(parse-body o s f bodies nuenv)))]
|
||
|
|
|
||
|
|
;; ---------------------------------------------------------
|
||
|
|
;; MzScheme specific code
|
||
|
|
|
||
|
|
;; --- units ---
|
||
|
|
[('unit ($ zodiac:list _ _ _
|
||
|
|
(($ zodiac:symbol _ _ _ 'import)
|
||
|
|
i-ids ...))
|
||
|
|
($ zodiac:list _ _ _
|
||
|
|
(($ zodiac:symbol _ _ _ 'export)
|
||
|
|
(or ($ zodiac:list _ _ _
|
||
|
|
(i-eids
|
||
|
|
($ zodiac:symbol _ _ _ e-eids)))
|
||
|
|
(and i-eids
|
||
|
|
($ zodiac:symbol _ _ _ e-eids)))
|
||
|
|
...))
|
||
|
|
. body)
|
||
|
|
(let*-vals ([(i-names env1) (do-bindings env i-ids)]
|
||
|
|
[(defs env2) (parse-defs body env1)]
|
||
|
|
[e-vars
|
||
|
|
(map (parse-sym-env env2) i-eids)]
|
||
|
|
[exports (map cons e-vars e-eids)])
|
||
|
|
(zodiac:make-unit-form o s f (box 0)
|
||
|
|
i-names exports defs))]
|
||
|
|
|
||
|
|
;; --- compound-units ---
|
||
|
|
[('compound-unit
|
||
|
|
($ zodiac:list _ _ _
|
||
|
|
(($ zodiac:symbol _ _ _ 'import)
|
||
|
|
($ zodiac:symbol _ _ _ imports) ...))
|
||
|
|
($ zodiac:list _ _ _
|
||
|
|
(($ zodiac:symbol _ _ _ 'link) . links))
|
||
|
|
($ zodiac:list _ _ _
|
||
|
|
(($ zodiac:symbol _ _ _ 'export) . exports)))
|
||
|
|
(let*-vals
|
||
|
|
([links
|
||
|
|
(map
|
||
|
|
(match-lambda
|
||
|
|
[($ zodiac:list _ _ _
|
||
|
|
(($ zodiac:symbol _ _ _ tag)
|
||
|
|
($ zodiac:list _ _ _ (exp . imports))))
|
||
|
|
(list tag
|
||
|
|
(parse exp env)
|
||
|
|
(apply append
|
||
|
|
(map
|
||
|
|
(match-lambda
|
||
|
|
[($ zodiac:symbol _ _ _ sym)
|
||
|
|
(list (cons #f sym))]
|
||
|
|
[($ zodiac:list _ _ _
|
||
|
|
(($ zodiac:symbol _ _ _ tag)
|
||
|
|
($ zodiac:symbol _ _ _ syms)
|
||
|
|
...))
|
||
|
|
(map (lambda (sym) (cons tag sym))
|
||
|
|
syms)]
|
||
|
|
[_ (syntax-error exp "Bad link imp")])
|
||
|
|
imports)))]
|
||
|
|
[_ (syntax-error exp "Bad link")])
|
||
|
|
links)]
|
||
|
|
[exports
|
||
|
|
(apply
|
||
|
|
append
|
||
|
|
(map
|
||
|
|
(match-lambda
|
||
|
|
[($ zodiac:list _ _ _
|
||
|
|
(($ zodiac:symbol _ _ _ tag)
|
||
|
|
(or ($ zodiac:list _ _ _
|
||
|
|
(($ zodiac:symbol _ _ _ i-eids)
|
||
|
|
($ zodiac:symbol _ _ _ e-eids)))
|
||
|
|
(and ($ zodiac:symbol _ _ _ i-eids)
|
||
|
|
($ zodiac:symbol _ _ _ e-eids))) ...))
|
||
|
|
(map
|
||
|
|
(lambda (i-eid e-eid) (list tag i-eid e-eid))
|
||
|
|
i-eids e-eids)]
|
||
|
|
[_ (syntax-error exp "Bad link export")])
|
||
|
|
exports))])
|
||
|
|
(zodiac:make-compound-unit-form
|
||
|
|
o s f (box 0) imports links exports))]
|
||
|
|
|
||
|
|
;; --- invoke-unit ---
|
||
|
|
[('invoke-unit exp . ((and vars ($ zodiac:symbol)) ...))
|
||
|
|
(zodiac:make-invoke-unit-form
|
||
|
|
o s f (box 0)
|
||
|
|
(parse exp env)
|
||
|
|
(map (lambda (var) (parse-sym var env)) vars))]
|
||
|
|
|
||
|
|
;; --- structures ---
|
||
|
|
[((or 'struct 'typed-structure 'const-typed-structure)
|
||
|
|
first
|
||
|
|
($ zodiac:list _ _ _ fields))
|
||
|
|
(let*-vals
|
||
|
|
([(tag parent)
|
||
|
|
(match first
|
||
|
|
[($ zodiac:symbol _ _ _ tag) (values tag #f)]
|
||
|
|
[($ zodiac:list _ _ _
|
||
|
|
(($ zodiac:symbol _ _ _ tag) parent))
|
||
|
|
(values tag (parse parent env))])]
|
||
|
|
[fields (map zodiac:stripper fields)])
|
||
|
|
(zodiac:make-struct-form
|
||
|
|
o s f (box 0)
|
||
|
|
tag (eq? sym 'const-typed-structure) parent fields))]
|
||
|
|
|
||
|
|
;; -------------------------------------------------------
|
||
|
|
;; MrSpidey specific code
|
||
|
|
|
||
|
|
[('poly exp)
|
||
|
|
(zodiac:make-poly-form
|
||
|
|
o s f (box 0) (parse exp env))]
|
||
|
|
[(': exp type)
|
||
|
|
(zodiac:make-:-form o s f (box 0)
|
||
|
|
(parse exp env)
|
||
|
|
(zodiac:stripper type))]
|
||
|
|
|
||
|
|
[('type:-quote
|
||
|
|
($ zodiac:list _ _ _
|
||
|
|
(($ zodiac:symbol _ _ _ (or 'quote '#%quote))
|
||
|
|
($ zodiac:list _ _ _ (type . attrs)))))
|
||
|
|
(zodiac:make-type:-form o s f (box 0)
|
||
|
|
(zodiac:stripper type)
|
||
|
|
(map zodiac:stripper attrs))]
|
||
|
|
|
||
|
|
[('st:control para val)
|
||
|
|
(zodiac:make-st:control-form o s f (box 0)
|
||
|
|
(zodiac:stripper para)
|
||
|
|
(zodiac:stripper val))]
|
||
|
|
|
||
|
|
[((or 'cache-exp-quote 'cache-inv-quote)
|
||
|
|
($ zodiac:list _ _ _
|
||
|
|
(($ zodiac:symbol _ _ _ (or 'quote '#%quote)) exp))
|
||
|
|
($ zodiac:string _ _ _ za))
|
||
|
|
(when (string=? za (regexp-replace ".za$" za ""))
|
||
|
|
(syntax-error exp "Cache filename must end in .za"))
|
||
|
|
(zodiac:make-cache-form
|
||
|
|
o s f (box 0) exp
|
||
|
|
(normalize-path za)
|
||
|
|
(case sym
|
||
|
|
[cache-exp-quote 'exp]
|
||
|
|
[cache-inv-quote 'inv]
|
||
|
|
[else
|
||
|
|
(mrspidey:internal-error 'parser "Bad sym ~s" sym)])
|
||
|
|
(current-directory))]
|
||
|
|
|
||
|
|
;; -------------------------------------------------------
|
||
|
|
[else (syntax-error exp)])]
|
||
|
|
[(memq sym define-keywords)
|
||
|
|
(syntax-error-no-exp exp "Defines not allowed")]
|
||
|
|
[else (fail)]))]
|
||
|
|
|
||
|
|
;; Don't handle vectors or improper lists
|
||
|
|
;; Applications
|
||
|
|
|
||
|
|
[($ zodiac:list o s f (and l (fn . exps)))
|
||
|
|
(zodiac:make-app o s f (box 0)
|
||
|
|
(parse fn env)
|
||
|
|
(parse-exps exps env))]
|
||
|
|
[($ zodiac:list o s f ())
|
||
|
|
(zodiac:make-quote-form o s f (box 0) '())]
|
||
|
|
[_ (syntax-error exp)]))))
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
(define (parse-defs defs env)
|
||
|
|
(let*-vals
|
||
|
|
([varss (mapLR
|
||
|
|
(match-lambda
|
||
|
|
[($ zodiac:list _ _ _
|
||
|
|
(($ zodiac:symbol _ _ _ '#%define-values)
|
||
|
|
($ zodiac:list _ _ _ vars)
|
||
|
|
exp))
|
||
|
|
vars]
|
||
|
|
[_ '()])
|
||
|
|
defs)]
|
||
|
|
[(boundss nuenv) (do-bindingss env varss)]
|
||
|
|
[_ (for-each
|
||
|
|
(lambda (name) (zodiac:set-bound-mutated! name #t))
|
||
|
|
(apply append boundss))]
|
||
|
|
[defs
|
||
|
|
(map
|
||
|
|
(lambda (def bounds)
|
||
|
|
(pretty-debug-front `(parse-def ,(zodiac:stripper def)))
|
||
|
|
(mrspidey:zprogress "Parsing" (zodiac:zodiac-start def))
|
||
|
|
(match def
|
||
|
|
;; Special forms
|
||
|
|
[($ zodiac:list o s f
|
||
|
|
(and l (($ zodiac:symbol _ _ _ sym) . body)))
|
||
|
|
(=> fail)
|
||
|
|
(let ([sym (strip-hash-percent sym)])
|
||
|
|
(cond
|
||
|
|
[(not (memq sym define-keywords)) (fail)]
|
||
|
|
[else
|
||
|
|
(match (cons sym body)
|
||
|
|
|
||
|
|
[('define-values ($ zodiac:list _ _ _ vars) exp)
|
||
|
|
(zodiac:make-define-values-form
|
||
|
|
o s f (box 0)
|
||
|
|
(map
|
||
|
|
(match-lambda
|
||
|
|
[(and bound ($ zodiac:bound o s f _ sym))
|
||
|
|
(zodiac:make-lexical-varref o s f (box 0)
|
||
|
|
sym bound)])
|
||
|
|
bounds)
|
||
|
|
(parse exp nuenv))]
|
||
|
|
|
||
|
|
;; ----------------------------------------------------
|
||
|
|
;; MrSpidey specific code
|
||
|
|
|
||
|
|
[('define-type ($ zodiac:symbol _ _ _ sym) type)
|
||
|
|
(zodiac:make-define-type-form
|
||
|
|
o s f (box 0)
|
||
|
|
sym (zodiac:stripper type))]
|
||
|
|
|
||
|
|
[('define-constructor ($ zodiac:symbol _ _ _ sym)
|
||
|
|
. modes)
|
||
|
|
(let ([modes (map zodiac:stripper modes)])
|
||
|
|
(assert-syn def (andmap boolean? modes))
|
||
|
|
(zodiac:make-define-constructor-form o s f (box 0)
|
||
|
|
sym modes))]
|
||
|
|
|
||
|
|
;; ----------------------------------------------------
|
||
|
|
[else (fail)])]))]
|
||
|
|
|
||
|
|
[exp (parse exp nuenv)]))
|
||
|
|
defs boundss)])
|
||
|
|
(unless (null? defs)
|
||
|
|
(mrspidey:zprogress "Parsing" (zodiac:zodiac-finish (rac defs))))
|
||
|
|
(values defs nuenv)))
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
|