;;; -*- Mode: Irken -*- (include "lib/core.scm") (include "lib/pair.scm") (include "lib/alist.scm") (include "lib/string.scm") (include "lib/frb.scm") (include "lib/symbol.scm") (include "lib/io.scm") (include "parse/lexstep.scm") (include "lib/lexer.scm") ;; parser tables (include "parse/t2.scm") (datatype item (:t symbol (range) string) (:nt symbol (range) (list (item))) ) (datatype stack (:empty) (:elem (item) int (stack)) ) ;; this isn't very modular. yet. I'd like to get a generator-based parse going on here. ;; might even obviate the need for tracking position in the AST. [since lexer position ;; can propagate to the current parse error]. (define (parse path) (let ((file (file/open-read path)) (token-gen (make-lex-generator file)) (paren-stack (list:nil)) (indents (list:cons 0 (list:nil))) (start-of-line #t) (held-token eof-token) (tok eof-token) ) (define get-indent ;; XXX handle or disallow tabs (token:t 'whitespace str _) -> (string-length str) ;; non-whitespace at the front of a line (token:t _ _ _) -> 0) (define (get-top-indent) (match indents with () -> 0 (indent . _) -> indent)) (define (next-token0) ;; process (i.e., filter/synthesize) the token stream (let loop () (cond ((not (eq? held-token eof-token)) (set! tok held-token) (set! held-token eof-token)) (else (set! tok (token-gen)) ;;(print "token-gen: ") (printn tok) )) ;;(print "next-token loop ") (printn start-of-line) (if start-of-line ;; in this state we might emit INDENT/DEDENT (match tok with (token:t sym val range) -> (let ((this-indent (get-indent tok)) (top-indent (get-top-indent))) (set! start-of-line #f) (set! held-token tok) (cond ((> this-indent top-indent) (set! indents (list:cons this-indent indents)) (token:t 'INDENT "" range)) ((< this-indent top-indent) (set! indents (cdr indents)) ;; go around again, might be more DEDENT (set! start-of-line #t) (token:t 'DEDENT "" range)) (else (loop))))) ;; in the middle of a line somewhere (match tok with (token:t 'NEWLINE _ _) -> (match paren-stack with () -> (begin (set! start-of-line #t) tok) _ -> (loop)) (token:t 'whitespace _ _) -> (loop) (token:t 'comment _ _) -> (loop) (token:t _ _ _) -> tok )) )) (define (next-token) (let ((t (next-token0))) (print-string "next-token: ") (printn t) t)) (let ((stack (stack:empty))) (define (get-state) (match stack with (stack:empty) -> 0 (stack:elem _ state _) -> state )) (define (lookup-action state kind) (let loop ((l actions[state])) (match l with (action-list:nil) -> (error "missing action?") (action-list:cons tkind action tl) -> (if (eq? terminals[tkind] kind) action (loop tl))))) (define (lookup-goto state nt) (let loop ((l goto[state])) (match l with (goto-list:nil) -> (error "missing goto?") (goto-list:cons nt0 new-state tl) -> (if (eq? nt0 nt) new-state (loop tl))))) (define (pop-n n) (let loop ((n n) (result (list:nil))) (if (= n 0) result (loop (- n 1) (list:cons (pop) result))))) (define (push item state) (set! stack (stack:elem item state stack))) (define (pop) (match stack with (stack:elem item _ rest) -> (begin (set! stack rest) item) (stack:empty) -> (error "stack underflow"))) (define (get-range args) (let loop ((args args) (l0 -1) (p0 -1) (l1 -1) (p1 -1)) (define test-range -1 tl (range:t l2 p2 l3 p3) -> (loop tl l2 p2 l3 p3) _ tl (range:t l2 p2 l3 p3) -> (loop tl l0 p0 l3 p3) _ tl (range:f) -> (loop tl l0 p0 l1 p1) ) (match l0 args with -1 () -> (range:f) _ () -> (range:t l0 p0 l1 p1) _ ((item:t _ r _) . tl) -> (test-range l0 tl r) _ ((item:nt _ r _) . tl) -> (test-range l0 tl r) ))) (let loop ((tok (next-token))) (cond ((eq? tok eof-token) (pop) (pop)) (else (print-string "token: ") (printn tok) ;;(print-string "state: ") (printn (get-state)) ;;(print "indentation: ") (printn indentation) (vcase token tok ((:t kind val range) (let ((a (lookup-action (get-state) kind))) (vcase action a ((:shift state) (push (item:t kind range val) state) (loop (next-token))) ((:reduce plen nt) (let ((args (pop-n plen)) (next-state (lookup-goto (get-state) nt))) (push (item:nt non-terminals[nt] (get-range args) args) next-state)) (loop tok))) ))) ))) ))) (define indent 0 -> #t n -> (begin (print-string " ") (indent (- n 1)))) (define (print-parse-tree t) (let loop0 ((d 0) (t t)) (indent d) (match t with (item:t sym range str) -> (begin (print range) (print-string " ") (print sym) (print-string " ") (printn str)) (item:nt sym range items) -> (begin (print range) (print-string " ") (printn sym) (let loop1 ((l items)) (match l with () -> #u (hd . tl) -> (begin (loop0 (+ d 1) hd) (loop1 tl))))) ))) ;; print a parse tree out in a way that facilitates writing patterns for it. (define ppt (item:nt sym range items) -> (begin (print-string "(item:nt ") (print sym) (print-string " ") (ppt-list items) (print-string ")")) (item:t sym range str) -> (begin (print-string "(item:t ") (print sym) (print-string " \"") (print-string str) (print-string "\")")) ) (define (ppt-list l) (print-string "(") (ppt-list2 l)) (define ppt-list2 () -> (print-string ")") (hd . tl) -> (begin (ppt hd) (print-string " ") (ppt-list2 tl)) ) (datatype formal (:var string) ;;(:var-with-default string (expr)) ) (datatype literal (:int int) (:string string) ) (datatype params (:literal (literal)) (:varref string) (:function string (list (formal))) ;;
(:unparsed symbol) (:for (list (formal))) (:none) ) (define (perror where x) (print-string "decode error in ") (print-string where) (print-string ": ") (printn x) (error "decode error")) (define p-operator (item:nt _ _ ((item:t kind _ data))) -> data (item:t _ _ data) -> data x -> (perror "p-operator" x)) (define NR (range:f)) (define (make-varref name) {t='varref p=(params:varref name) subs='() range=NR}) (define p-binary-splat e () -> e e (op arg (item:nt _ _ splat)) -> {t='call p=(params:none) subs=(LIST (make-varref (p-operator op)) e (p-binary-splat (p-expr arg) splat)) range=NR} e x -> (perror "p-binary-splat" x) ) (define p-binary (e (item:nt _ _ splat)) -> (p-binary-splat (p-expr e) splat) x -> (perror "p-binary" x)) (define p-power (arg0 trailer (item:nt _ _ splat)) -> (p-binary-splat (p-trailer-splat (p-expr arg0) trailer) splat) x -> (perror "p-power" x)) (define p-factor (unary f) -> {t='call p=(params:none) subs=(LIST (make-varref (p-operator unary)) (p-expr f)) range=NR} (power) -> (p-expr power) x -> (perror "p-factor" x)) (define p-trailer-splat exp0 (item:nt _ _ ()) -> exp0 exp0 (item:nt _ _ (trailer splat)) -> (p-trailer-splat (p-trailer exp0 trailer) splat) exp0 x -> (perror "p-trailer-splat" x) ) (define __getitem__ {t='varref p=(params:varref "__getitem__") subs='() range=NR}) (define __getattr__ {t='varref p=(params:varref "__getattr__") subs='() range=NR}) (define pass-node {t='pass p=(params:none) subs='() range=NR}) (define (literal-string s r) {t='literal p=(params:literal (literal:string s)) subs='() range=r}) (define p-trailer exp0 (item:nt _ _ ((item:t 'lparen _ _) arglist _)) -> {t='call p=(params:none) subs=(list:cons exp0 (p-arglist arglist)) range=NR} exp0 (item:nt _ _ ((item:t 'lbracket _ _) exp1 _)) -> {t='call p=(params:none) subs=(LIST __getitem__ exp0 (p-expr exp1)) range=NR} exp0 (item:nt _ _ ((item:t 'dot _ _) (item:t 'NAME nr name))) -> {t='call p=(params:none) subs=(LIST __getattr__ exp0 (literal-string name nr)) range=NR} exp0 x -> (perror "p-trailer" x) ) (define p-arglist (item:nt _ _ ()) -> (list:nil) _ -> (error "arglist")) (define (p-formals formals) (define p-formals0 () -> (list:nil) (_ (item:t _ _ name) (item:nt _ _ splat)) -> (list:cons (formal:var name) (p-formals0 splat)) x -> (perror "p-formals0" x)) (match formals with (item:nt _ _ ((item:t _ _ name0) (item:nt _ _ splat) _)) -> (list:cons (formal:var name0) (p-formals0 splat)) x -> (perror "p-formals" x))) (define p-funcdef ;; 'def' NAME '('