From 7f016e2754513ee0cc308745ed1608fdae338a29 Mon Sep 17 00:00:00 2001 From: Erik Silkensen Date: Wed, 5 Sep 2012 02:38:05 -0400 Subject: [PATCH] removing src --- src/bidi-edge.rkt | 144 ---- src/chart-parser.rkt | 931 ------------------------- src/es.rkt | 1261 ---------------------------------- src/grammar.rkt | 280 -------- src/lexer.rkt | 880 ------------------------ src/test-compile/Fun.es | 21 - src/test-compile/ML.es | 28 - src/test-compile/PairFun.es | 37 - src/test-compile/Sets.es | 26 - src/test-compile/Vector.es | 8 - src/test-compile/abc.es | 10 - src/test-compile/double.es | 10 - src/test-compile/fact.es | 12 - src/test-compile/fun1.es | 7 - src/test-compile/fun2.es | 9 - src/test-compile/fun3.es | 9 - src/test-compile/fun4-ill.es | 12 - src/test-compile/fun4.es | 12 - src/test-compile/let.es | 6 - src/test-compile/p1.es | 10 - src/test-compile/vec.es | 8 - src/test-lexer.rkt | 24 - src/test-parse/Arith1.es | 8 - src/test-parse/Arith2.es | 8 - src/test-parse/BTO.es | 21 - src/test-parse/Lambda.es | 9 - src/test-parse/LetExp.es | 8 - src/test-parse/MA.es | 12 - src/test-parse/Param.es | 11 - src/test-parse/TIL.es | 40 -- src/test-parse/gemver.ast | 46 -- src/test-parse/gemver.es | 16 - src/test-parse/if1.ast | 14 - src/test-parse/if1.es | 5 - src/test-parse/lc.ast | 21 - src/test-parse/lc.es | 5 - src/test-parse/let0.ast | 23 - src/test-parse/let0.es | 5 - src/test-parse/let1.ast | 13 - src/test-parse/let1.es | 3 - src/test-parse/mult.ast | 18 - src/test-parse/mult.es | 5 - src/test-parse/prec1.ast | 8 - src/test-parse/prec1.es | 3 - src/test-parse/prec2.ast | 10 - src/test-parse/prec2.es | 3 - src/test-parse/til-fact.ast | 38 - src/test-parse/til-fact.es | 15 - src/test-parser.rkt | 39 -- src/utils.rkt | 63 -- 50 files changed, 4215 deletions(-) delete mode 100644 src/bidi-edge.rkt delete mode 100644 src/chart-parser.rkt delete mode 100644 src/es.rkt delete mode 100644 src/grammar.rkt delete mode 100644 src/lexer.rkt delete mode 100644 src/test-compile/Fun.es delete mode 100644 src/test-compile/ML.es delete mode 100644 src/test-compile/PairFun.es delete mode 100644 src/test-compile/Sets.es delete mode 100644 src/test-compile/Vector.es delete mode 100644 src/test-compile/abc.es delete mode 100644 src/test-compile/double.es delete mode 100644 src/test-compile/fact.es delete mode 100644 src/test-compile/fun1.es delete mode 100644 src/test-compile/fun2.es delete mode 100644 src/test-compile/fun3.es delete mode 100644 src/test-compile/fun4-ill.es delete mode 100644 src/test-compile/fun4.es delete mode 100644 src/test-compile/let.es delete mode 100644 src/test-compile/p1.es delete mode 100644 src/test-compile/vec.es delete mode 100644 src/test-lexer.rkt delete mode 100644 src/test-parse/Arith1.es delete mode 100644 src/test-parse/Arith2.es delete mode 100644 src/test-parse/BTO.es delete mode 100644 src/test-parse/Lambda.es delete mode 100644 src/test-parse/LetExp.es delete mode 100644 src/test-parse/MA.es delete mode 100644 src/test-parse/Param.es delete mode 100644 src/test-parse/TIL.es delete mode 100644 src/test-parse/gemver.ast delete mode 100644 src/test-parse/gemver.es delete mode 100644 src/test-parse/if1.ast delete mode 100644 src/test-parse/if1.es delete mode 100644 src/test-parse/lc.ast delete mode 100644 src/test-parse/lc.es delete mode 100644 src/test-parse/let0.ast delete mode 100644 src/test-parse/let0.es delete mode 100644 src/test-parse/let1.ast delete mode 100644 src/test-parse/let1.es delete mode 100644 src/test-parse/mult.ast delete mode 100644 src/test-parse/mult.es delete mode 100644 src/test-parse/prec1.ast delete mode 100644 src/test-parse/prec1.es delete mode 100644 src/test-parse/prec2.ast delete mode 100644 src/test-parse/prec2.es delete mode 100644 src/test-parse/til-fact.ast delete mode 100644 src/test-parse/til-fact.es delete mode 100644 src/test-parser.rkt delete mode 100644 src/utils.rkt diff --git a/src/bidi-edge.rkt b/src/bidi-edge.rkt deleted file mode 100644 index 6660282..0000000 --- a/src/bidi-edge.rkt +++ /dev/null @@ -1,144 +0,0 @@ -;;;;;; bidi-edge.rkt - Bidirectional Edge module. -*- Mode: Racket -*- -;;;;;; Author: Erik Silkensen -;;;;;; Version: 3 Sep 2012 - -#lang typed/racket/no-check - -(require - "grammar.rkt" - "lexer.rkt" - "utils.rkt") - -(provide (all-defined-out)) - -(struct edge - (start end lhs left found right assoc prec vars code src) - #:transparent) - -(define (edge-list? x) - (and (list? x) - (andmap edge? x))) - -(define-match-expander edge-complete - (syntax-rules () - [(edge-complete lhs found) - (edge _ _ lhs '() found '() _ _ _ _ _)])) - -(define (edge-complete? E) - (and (null? (edge-left E)) (null? (edge-right E)))) - -(define (edge-incomplete? E) - (not (edge-complete? E))) - -(define (edge->string E) - (match E - [(edge start end lhs left found right assoc prec vars code src) - (format "[~a,~a, ~a -> ~a . ~a . ~a vars=~a src=~a]" - start end lhs (edge->string left) (edge->string found) - (edge->string right) vars src)] - [(? null? E) ""] - [(? list? E) (format "~a" (map edge->string E))] - [else (format "~a" E)])) - -(: edge->ast - (case-> [edge -> (Listof Sexp)] - [edge Boolean -> (Listof Sexp)])) -(define (edge->ast E [terminals? #f]) - (define (as? obj) - (or (edge? obj) - (and (pair? obj) - (or terminals? - (and (rule-lhs? (car obj)) - (not (string? (car obj)))))))) - (if (edge? E) - `(,(car (edge->ast (edge-lhs E) #f)) - ,@(map (λ (e) - (match e - [(? edge? e) (edge->ast e terminals?)] - [(? sexp? e) (car (edge->ast e terminals?))] - [(cons (? sexp? e1) (? token? e2)) - (car (edge->ast (cons e1 (token-value e2)) terminals?))] - [_ (error "edge->ast unexpected:" e)])) - (if (list1? (edge-found E)) - (edge-found E) - (filter as? (edge-found E))))) - (if (and (pair? E) - (string? (car E))) - (list (car E)) - (list E)))) - -(: parse-type (edge -> SExpr)) -(define (parse-type E) - (match (edge-found E) - [(list (cons '*Name (? token? t))) - (string->symbol (token-value t))] - [_ (let* ([code (edge-code E)] - [proc (cdr code)] - [formals (car code)]) - (let ([ret (proc (map (λ (f) - (lookup (edge-vars E) f)) - formals))]) - (if (sexpr? ret) - ret - (error "expected SExpr; got:" ret))))])) - -(: lookup - (All (T) - (case-> [(HashTable LHS Any) LHS -> Any] - [(HashTable LHS Any) LHS (-> T) -> Any]))) -(define (lookup vars A [failure-result (λ () #f)]) - (cond [(symbol? A) - (hash-ref vars A (λ () - (let ([B (symbol->string A)]) - (lookup vars B failure-result))))] - [(string? A) - (match (hash-ref vars A (λ () #f)) - [(list (cons (? string? s) _)) - (string->symbol s)] - [(list (cons (? edge? e) 'Type)) - (parse-type e)] - [(list (cons (? edge? e) _)) - (unparse e)] - [else (failure-result)])] - [(and (rule-lhs? A) (list? A)) - (map (λ (a) - (lookup vars a (λ () a))) - A)] - [else (failure-result)])) - -(: unparse - (case-> [(U Edge-Term Term) -> String] - [(U Edge-Term Term) String -> String])) -(define (unparse E [sep ""]) - (cond [(and (edge? E) edge-complete? E) - (string-join (map (λ (F) - (unparse F sep)) - (edge-found E)) sep)] - [(and (pair? E) (token? (cdr E))) (token-value (cdr E))] - [(string? E) E] - [(rule-lhs? E) (format "~a" E)] - [else (error "unparse unexpected:" E)])) - -(: leaf-count (Any -> Natural)) -(define (leaf-count node) - (match node - ['() 0] - [(list (? symbol?) (? string?)) 1] - [(? list? node) - (foldl + 0 (map leaf-count (cdr node)))] - [(? pair?) 1])) - -(: edge-leaf-count (Any -> Natural)) -(define (edge-leaf-count E) - (if (and (edge? E) - (edge-complete? E)) - (leaf-count (edge->ast E)) - 0)) - -(: get-last-token (edge -> (Option token))) -(define (get-last-token e) - (and (not (null? (edge-found e))) - (match (last (edge-found e)) - [(cons _ (? token? t)) t] - [(? token? t) t] - [(? edge? f) (get-last-token f)]))) diff --git a/src/chart-parser.rkt b/src/chart-parser.rkt deleted file mode 100644 index 60d838e..0000000 --- a/src/chart-parser.rkt +++ /dev/null @@ -1,931 +0,0 @@ -;;;;;; chart-parser.rkt - Chart Parser module. -*- Mode: Racket -*- -;;;;;; Author: Erik Silkensen -;;;;;; Version: 3 Sep 2012 - -#lang typed/racket/no-check - -(require - "bidi-edge.rkt" - "grammar.rkt" - "lexer.rkt" - "utils.rkt") - -(provide (all-defined-out)) - -(define-type Chart - (Pairof (Vectorof (Listof edge)) - (Vectorof (Listof edge)))) - -(define (binding? x) - (and (pair? x) - (string? (car x)))) - -(struct: parser-state - ([chart : Chart] - [depend : (HashTable edge (Listof edge))] - [spec : (HashTable Symbol (Listof LHS))] - [counts : (HashTable LHS Integer)] - [stats : (HashTable LHS Integer)] - [agenda : (Listof edge)] - [aux : (Listof (Listof edge))])) - -(struct: parser-ops - ([init-state : (Option parser-state)] - [ret-state? : Boolean] - [left? : Boolean] - [top-down? : Boolean] - [spec? : Boolean] - [trace? : Boolean] - [report? : Boolean])) - -(struct: agenda-state - ([edges : (Listof edge)] - [aux : (Listof (Listof edge))] - [hook : (-> Any)])) - -(define *match-trace?* #f) - -(: chart-parse - ((Vectorof token) grammar (edge (Listof edge) -> (Listof edge)) LHS - parser-ops -> (U (Vectorof (Listof edge)) parser-state))) -(define (chart-parse tokens grammar enqueue S ops) - (define init-state (parser-ops-init-state ops)) - (define top-down? (parser-ops-top-down? ops)) - (define trace? (parser-ops-trace? ops)) - (define chart - (if init-state (parser-state-chart init-state) - (initial-chart tokens (parser-ops-top-down? ops) grammar))) - (define chart-depend - (if init-state (parser-state-depend init-state) (make-hash))) - (define param-spec - (if init-state (parser-state-spec init-state) (make-hash))) - (define counts - (if init-state (parser-state-counts init-state) (make-hash))) - (define stats - (if init-state (parser-state-stats init-state) (make-hash))) - (define agenda - (let* ([edges (if init-state (parser-state-agenda init-state) - (initial-agenda tokens grammar S top-down?))] - [aux (if init-state (parser-state-aux init-state) '())] - [hook (λ () - (when (parser-ops-report? ops) - (report stats)) - (if (parser-ops-ret-state? ops) - (parser-state chart chart-depend param-spec - counts stats edges aux) - (cdr chart)))]) - (list (agenda-state edges aux hook)))) - - (: process-edge! (edge -> Void)) - (define (process-edge! E) - (unless (in-chart? E) - (add-to-chart! E 'process-edge!) - (if (edge-incomplete? E) - (begin (when (close-rec? E) - (let ([a '()] - [b '()] - [c (mk-close-rec E)]) - (set! agenda (cons (agenda-state a b c) agenda)))) - (forward-fundamental-rule E) - (when top-down? (top-down-rule E))) - (begin (backward-fundamental-rule E) - (unless top-down? (bottom-up-rule E)))))) - - (: forward-fundamental-rule (edge -> Void)) - (define (forward-fundamental-rule E) - ;; E : [i,j, A -> alpha B . beta . D delta] - ;; for all [h,i, B -> . gamma .] or [j,k, D -> . gamma .], add - ;; [h,j, A -> alpha . B beta . D delta] or - ;; [i,k, A -> alpha B . beta D . delta] to the agenda - (: mk-compl? (Integer Term (edge -> Integer) -> (edge -> Boolean))) - (define (mk-compl? n B/D edge-pt) - (λ (e) - (and (edge-complete? e) - (or (match? B/D (edge-lhs e)) - (let ([vars* (hash-copy (edge-vars E))]) - (match! B/D (edge-lhs e) vars* (edge-src E) e)) - (let ([vars* (hash-copy (edge-vars E))]) - (match* B/D e vars* (edge-src E)))) - (= n (edge-pt e))))) - (match E - [(edge i j A alpha beta delta assoc prec vars code src) - (let ([ffr (λ (n B/D edge-pt pt gen-dir) - (let ([compl? (mk-compl? n B/D edge-pt)]) - (for ([e (chart-filter compl? chart n pt)]) - (let-values ([(i j l f r) (gen-dir e)]) - (let ([vars* (hash-copy vars)]) - (when (or - (match? B/D (edge-lhs e)) - (let ([vars** (hash-copy vars*)]) - (and (match! B/D (edge-lhs e) vars** src e) - (begin (set! vars* vars**) #t))) - (let ([vars** (hash-copy vars*)]) - (and (match* B/D e vars** src) - (begin (set! vars* vars**) #t)))) - (set! A (param-subst A l f r vars*)) - (let ([b/d (edge i j A l f r - assoc prec vars* code src)]) - (when (edge? B/D) - (add-to-depend! B/D b/d 'ffr)) - (add-to-agenda! b/d 'ffr))))))))] - [gen-left (λ (e) - (values (edge-start e) j (drop-right alpha 1) - (append (compl-edge e) beta) delta))] - [gen-right (λ (e) - (values i (edge-end e) alpha - (append beta (compl-edge e)) (cdr delta)))]) - (unless (or (not (parser-ops-left? ops)) (null? alpha)) - (ffr i (last alpha) edge-end 'end gen-left)) - (unless (null? delta) - (ffr j (first delta) edge-start 'start gen-right)))])) - - (: top-down-rule (edge -> Void)) - (define (top-down-rule E) - ;; E : [i,j, A -> alpha B . beta . D delta] - ;; for all B ::= gamma; or D ::= gamma; in the grammar, add - ;; [i,i, B -> . . gamma] or [j,j, D -> . . gamma] to the agenda - (: pred-td (Integer Term (HashTable LHS Any) -> Void)) - (define (pred-td n B/D vars) - (let ([lhs (if (binding? B/D) (cdr B/D) - (if (rule-lhs? B/D) B/D #f))]) - (when (and (rule-lhs? lhs) (not (string? lhs))) - (let ([param? (eq? #f (hash-ref vars lhs (λ () lhs)))]) - (for ([r (if param? (all-rules grammar) - (rewrites-for lhs grammar))]) - (match r - [(rule lhs rhs assoc prec vars code src) - (let* ([vs (hash-copy vars)] - [e (edge n n lhs '() '() rhs assoc prec vs code src)]) - (add-to-depend! E e 'pred-td) ;; is this right? - (add-to-agenda! e 'pred-td))])))))) - (match-let ([(edge i j A alpha beta delta assoc prec vars code src) E]) - (unless (or (not (parser-ops-left? ops)) (null? alpha)) - (pred-td i (last alpha) vars)) - (unless (null? delta) - (pred-td j (first delta) vars)))) - - (: backward-fundamental-rule (edge -> Void)) - (define (backward-fundamental-rule E) - ;; E : [j,k, B -> . gamma .] -> Void - ;; for all [k,l, A -> alpha B . beta . delta] or - ;; [i,j, A -> alpha . beta . B delta], add - ;; [j,l, A -> alpha . B beta . delta] or - ;; [i,k, A -> alpha . beta B . delta] to the agenda - (: mk-compl? (Integer Term (edge -> Integer) (edge -> (Listof Term)) - ((Listof Term) -> Term) -> (edge -> Boolean))) - (define (mk-compl? n B/D edge-pt edge-dir sel) - (λ (e) - (and (not (null? (edge-dir e))) - (or (match? (sel (edge-dir e)) B/D) - (let ([vars* (hash-copy (edge-vars e))]) - (match! (sel (edge-dir e)) B/D vars* (edge-src e) E)) - (let ([vars* (hash-copy (edge-vars e))]) - (match* (sel (edge-dir e)) E vars* (edge-src e)))) - (= n (edge-pt e))))) - (: mk-left? (Integer Term -> (edge -> Boolean))) - (define (mk-left? k B) (mk-compl? k B edge-start edge-left last)) - (: mk-right? (Integer Term -> (edge -> Boolean))) - (define (mk-right? j B) (mk-compl? j B edge-end edge-right first)) - (: bfr - (Integer Term (Integer Term -> (edge -> Boolean)) (U 'start 'end) - (Integer Integer (Listof Term) (Listof Edge-Term) (Listof Term) - -> (Values Integer Integer (Listof Term) - (Listof Edge-Term) (Listof Term))) -> Void)) - (define (bfr n B compl? pt gen-dir) - (for ([e (chart-filter (compl? n B) chart n pt)]) - (match e - [(edge i j A alpha beta delta assoc prec vars code src) - (let-values ([(i j l f r) (gen-dir i j alpha beta delta)]) - (let ([sel (if (eq? 'end pt) first last)] - [edge-dir (if (eq? 'end pt) edge-right edge-left)]) - (when (or (match? (sel (edge-dir e)) B) - (let ([vars* (hash-copy vars)]) - (and (match! (sel (edge-dir e)) B vars* src E) - (begin (set! vars vars*) #t))) - (let ([vars* (hash-copy vars)]) - (and (match* (sel (edge-dir e)) E vars* src) - (begin (set! vars vars*) #t)))) - (set! A (param-subst A l f r vars)) - (let ([b (edge i j A l f r assoc prec vars code src)]) - (for ([f beta]) - (when (edge? f) - (add-to-depend! f b 'bfr))) - (add-to-depend! E b 'bfr) - (add-to-agenda! b 'bfr)))))]))) - (match E - [(edge j k B '() gamma '() _ _ _ _ _) - (let ([gen-left (λ (k l a b d) - (values j l (drop-right a 1) - (append (compl-edge E) b) d))] - [gen-right (λ (i j a b d) - (values i k a (append b (compl-edge E)) (cdr d)))]) - (when (parser-ops-left? ops) - (bfr k B mk-left? 'start gen-left)) - (bfr j B mk-right? 'end gen-right))])) - - (: bottom-up-rule (edge -> Void)) - (define (bottom-up-rule E) - ;; E : [i,j, B -> . gamma .] -> Void - ;; for all A ::= alpha B beta; in the grammar, add - ;; [i,j, A -> alpha . B . beta] to the agenda - (match E [(edge i j B '() gamma '() _ _ _ _ _) - (let ([expand? (and (not (null? gamma)) - (or (not (parser-ops-left? ops)) - (should-expand? B grammar)))]) - (for ([r (expand-rules (grammar-rules grammar))]) - (let ([assoc (rule-assoc r)] - [prec (rule-prec r)] - [vars0 (rule-vars r)] - [code (rule-code r)] - [src (rule-src r)] - [left-aux '()]) - (let loop ([alpha '()] [beta (rule-rhs r)]) - (unless (or (null? beta) - (not (or (parser-ops-left? ops) (null? alpha))) - (> (length alpha) i)) - (let ([b (car beta)] - [vars (hash-copy vars0)]) - (when (and (or (match? b B) - (let ([vars* (hash-copy vars)]) - (and (match! b B vars* src E) - (set! vars vars*) #t)) - (let ([vars* (hash-copy vars)]) - (and (match* b E vars* src) - (set! vars vars*) #t))) - expand?) - (let ([A (rule-lhs r)] - [C (compl-edge E)] - [D (cdr beta)]) - (set! A (param-subst A alpha C D vars)) - (let ([e (edge i j A alpha C D assoc prec vars code src)]) - (cond - [(null? alpha) - (add-to-depend! E e 'pred-bu) - (add-to-agenda! e 'pred-bu)] - [(and (rule-lhs? (last alpha)) - (not (string? (last alpha)))) - (add-to-depend! E e 'pred-bu) - (set! left-aux (cons e left-aux))] - [else - (let ([a (last alpha)]) - (if (list1? - (chart-filter - (λ (f) - (and ;;(= (- i 1) (edge-start f)) - (= i (edge-end f)) - (edge-complete? f) - (equal? a (edge-lhs f)))) - chart - i 'end)) - (begin - (add-to-depend! E e 'pred-bu) - (add-to-agenda! e 'pred-bu)) - (begin - (add-to-depend! E e 'pred-bu) - (set! left-aux (cons e left-aux)))))])))) - (loop (append alpha (list b)) (cdr beta))))) - (add-to-aux! left-aux 'pred-bu))) - (when (string? B) - (match gamma - [(list (? token? b)) - (for ([A (category B grammar)]) - (let* ([src (cons (grammar-id grammar) 'rec)] - [vars (make-hash)] - [found (list (cons B b))] - [e (edge i j A '() found '() '⊥ '⊥ vars #f src)]) - (add-to-depend! E e 'scan-bu) - (add-to-agenda! e 'scan-bu)))] - [_ (error "expected token:" gamma)])))])) - - (: close-rec? (edge -> Boolean)) - (define (close-rec? E) - (match E - [(edge i j A+ '() gamma (list A+) _ _ _ _ _) - (rule-rec? A+)] - [else #f])) - - (: mk-close-rec (edge -> (-> Void))) - (define (mk-close-rec E) - (match E [(edge i j A+ '() gamma (list A+) assoc prec vars code src) - (let* ([A (rule-base A+)] [c (hash-ref counts A)]) - (λ () - (when (= c (hash-ref counts A)) - (let ([e (edge i j A+ '() gamma '() assoc prec vars code src)]) - (add-to-agenda! e 'close-rec)))))])) - - (: in-chart? (edge -> Boolean)) - (define (in-chart? E) - (or (not (not (member E (vector-ref (car chart) (edge-start E))))) - (not (not (member E (vector-ref (cdr chart) (edge-end E))))))) - - (: add-to-chart! (edge Symbol -> Void)) - (define (add-to-chart! E caller) - (: add! (edge Integer (Vectorof (Listof edge)) -> Void)) - (define (add! E j chart) - (let ([lst (vector-ref chart j)]) - (unless (member E lst) - ;;(hash-update! stats caller (λ (c) (+ c 1)) 0) - ;;(hash-update! stats (edge-lhs E) (λ (c) (+ c 1)) 0) - (vector-set! chart j (cons E lst))))) - (unless (edge? E) - (error (format "~a tried to add a non-edge to the chart:~n~a" - caller E))) - (when (not (null? (edge-found E))) - (let ([update (λ (c) (+ c 1))] - [zero (λ () 0)]) - (hash-update! counts (edge-lhs E) update zero))) - (when trace? (log-trace (format "~a.chart" caller) E)) - (add! E (edge-start E) (car chart)) - (add! E (edge-end E) (cdr chart))) - - (: add-to-agenda! (edge Symbol -> Void)) - (define (add-to-agenda! E caller) - (unless (edge? E) - (error (format "~a tried to add a non-edge to the agenda:~n~a" - caller E))) - (unless (member E (agenda-state-edges (car agenda))) - (when (and #t trace?) (log-trace (format "~a.agenda" caller) E)) - (let ([update (λ (c) (+ c 1))] - [zero (λ () 0)]) - (hash-update! stats caller update zero) - (hash-update! stats (edge-lhs E) update zero)) - (match (car agenda) - [(agenda-state es aux hook) - (let ([fs (enqueue E es)]) - (set! agenda (cons (agenda-state fs aux hook) (cdr agenda))))]))) - - (: add-to-aux! ((Listof edge) Symbol -> Void)) - (define (add-to-aux! ES caller) - (match-let ([(agenda-state edges aux hook) (car agenda)]) - (unless (null? ES) - (when (and #f trace?) - (printf "~a.aux:~n" caller) - (for ([e ES]) (printf " ~a~n" (edge->string e)))) - (let ([as (agenda-state edges (cons ES aux) hook)]) - (set! agenda (cons as (cdr agenda))))))) - - (: add-to-depend! (edge edge Symbol -> Void)) - (define (add-to-depend! E F caller) - ;; set F depends on E - (let ([e (equal-hash-code E)]) - (unless (eq? e (equal-hash-code F)) - (let ([update (λ (l) (cons F l))] - [null (λ () '())]) - (hash-update! chart-depend E update null))))) - - (: remove-from-chart! (edge Symbol -> Void)) - (define (remove-from-chart! E caller) - (: remove! (edge Integer (Vectorof (Listof edge)) -> Void)) - (define (remove! E j chart) - (let ([lst (vector-ref chart j)]) - (vector-set! chart j (remove E lst)))) - (when trace? (log-trace (format "~a.remove!" caller) E)) - (when (in-chart? E) - (let ([null (λ () '())]) - (remove! E (edge-start E) (car chart)) - (remove! E (edge-end E) (cdr chart)) - (for-each (λ (e) - (remove-from-chart! e caller)) - (hash-ref chart-depend E null))))) - - (: match? (Term Term -> Boolean)) - (define (match? A B) - (when (and *match-trace?* trace?) - (printf "match?~n A = ~a~n B = ~a~n" - (pretty-format A) (pretty-format B))) - (cond [(string? A) - (and (string? B) - (string=? A B))] - [(regexp? A) - (and (string? B) - (not (not (regexp-match A B))))] - [(procedure? A) - (and (string? B) - (not (not (A B))))] - [(rule-lhs? A) - (equal? A B)] - [else #f])) - - (: match! - (Term Term (HashTable LHS Any) (Pairof Symbol Symbol) edge -> Boolean)) - (define (match! A B vars src E) - ;; A is parameterized variable; vars and src belong to A's edge; - ;; update vars if necessary - (when (and *match-trace?* trace? - (or (rule-lhs? A) (binding? A)) (rule-lhs? B)) - (printf "match!~n A = ~a~n B = ~a~n" - (pretty-format A) (pretty-format B))) - (if (and (binding? A) (rule-lhs? B) (not (string? B)) - (string? (car A)) (rule-lhs? (cdr A)) (not (string? (cdr A))) - (match! (cdr A) B vars src E) - (edge-complete? E)) - (let ([val (or (and (parsed-lexical? E) (unparse E)) E)] - [type (hash-ref vars (car A))]) - (if (pair? type) - (begin - (hash-set! vars (car A) (list (cons val (cdr type)))) #t) - (error "expected pair:" type))) - (and (rule-lhs? A) (rule-lhs? B) - (not (string? A)) (not (string? B)) - (or (match-param! A B vars src) - (match? A B) - (and (list? A) (list? B) - (= (length A) (length B)) - (andmap (λ (a b) - (match! a b vars src E)) - A B)))))) - - (: match-param! - (Term Term (HashTable LHS Any) (Pairof Symbol Symbol) -> Boolean)) - (define (match-param! A B vars src) - (: already-more-specific? (LHS -> Boolean)) - (define (already-more-specific? t) - (and (rule-lhs? B) (not (string? B)) (more-specific? t B grammar))) - (when (and *match-trace?* trace? (rule-lhs? A) (rule-lhs? B) - (not (string? A)) (not (string? B))) - (printf "match-param!~n A = ~a~n B = ~a~n" - (pretty-format A) (pretty-format B))) - (and (rule-lhs? A) (rule-lhs? B) - (not (string? A)) (not (string? B)) - (hash-has-key? vars A) - (let ([a (hash-ref vars A)]) - (or (and (rule-lhs? a) (not (string? a)) - (match? a B)) - (and (eq? a #f) - (let ([k (cdr src)] - [v (λ (l) l)] - [null (λ () '())]) - (hash-update! param-spec k v null) - (let ([ts (hash-ref param-spec k)]) - ;; param-spec optimization: - ;; don't allow any subs when B is - ;; less specific than any prev sub - (and (not (ormap already-more-specific? ts)) - (begin (hash-set! vars A B) - (hash-update! - param-spec k - (λ (l) - (cons B l))) - #t))))))))) - - (: match* - (Term edge (HashTable LHS Any) (Pairof Symbol Symbol) -> Boolean)) - (define (match* A B vars src) - ;; A is a pair of String x Symbol for a bound variable e.g. - ;; x:Id = ("x" . Id) and B is an edge to match against the cdr; - ;; if successful, bind the variable to the parse of B e.g. - ;; B = [i,j, Id -> . gamma .] and "x" : (gamma . _) in vars. - (: get-val (edge -> (U edge String))) - (define (get-val B) - (or (and (parsed-lexical? B) (unparse B)) B)) - (when (and *match-trace?* trace? (binding? A) (edge? B)) - (printf "match*~n A = ~a~n B = ~a~n" - (pretty-format A) (edge->string B))) - (and (binding? A) (edge? B) - (match? (cdr A) (edge-lhs B)) - (hash-has-key? vars (car A)) - (let ([val-type (hash-ref vars (car A))]) - (and (pair? val-type) - (not (car val-type)) - (let ([val (get-val B)] - [type (cdr val-type)]) - (hash-set! vars (car A) (list (cons val type))) - #t))))) - - (: assoc-check? (edge edge -> (Option edge))) - (define (assoc-check? a b) - ;; if a and b are ambiguous based on associativity, then return the - ;; one that can be removed; otherwise, return #f. - (define (td-check? A B) - (let ([ac (edge-leaf-count A)] - [bc (edge-leaf-count B)]) - (cond [(< ac bc) a] - [(< bc ac) b] - [else #f]))) - (match (cons a b) - [(cons (edge i k A '() gamma '() assoc prec vars code src) - (edge j l A* '() gamma* '() assoc* prec* vars* code* src*)) - (and (not (eq? a b)) - (equal? A A*) - (not (eq? '⊥ assoc)) - (eq? assoc assoc*) - (pair? src) (pair? src*) - (eq? (cdr src) (cdr src*)) - (or (and (= 3 (length gamma)) - (= 3 (length gamma*))) - (and (= 2 (length gamma)) - (= 2 (length gamma*)))) - (let ([B (first gamma)] [D (last gamma)] - [B* (first gamma*)] [D* (last gamma*)]) - (or (and (> k j) (> l k) - (equal? D B*) - (if (eq? assoc 'right) a b)) - (and (> i j) (> l i) - (equal? B D*) - (if (eq? assoc 'right) b a)) - (and (= i j) (= k l) - (if (eq? assoc 'right) - (td-check? D D*) - (td-check? B B*))))))] - [else #f])) - - (: prec-check? (edge edge -> (Option edge))) - (define (prec-check? a b) - ;; if a and b are ambiguous based on precedence, then return the - ;; one that can be removed; otherwise, return #f. - (match (cons a b) - [(cons (edge i k A '() gamma '() assoc prec vars code src) - (edge j l A* '() gamma* '() assoc* prec* vars* code* src*)) - (and (not (eq? a b)) - (pair? src) (pair? src*) - (eq? (car src) (car src*)) - (integer? prec) (integer? prec*) - (or (and (= i j) (= k l) - (or (and (> prec prec*) a) - (and (> prec* prec) b))) - (and (or (and (> k j) (> l k) - (equal? (last gamma) (first gamma*))) - (and (> i j) (> l i) - (equal? (first gamma) (last gamma*)))) - (or (and (> prec prec*) b) - (and (> prec* prec) a)))))] - [else #f])) - - (: spec-check? (edge edge -> (Option edge))) - (define (spec-check? a b) - (match (cons a b) - [(cons (edge i k A '() gamma '() assoc prec vars code src) - (edge j l A* '() gamma* '() assoc* prec* vars* code* src*)) - (and (not (eq? a b)) - (= i j) (= k l) - (not (equal? a b)) - (or (and (more-specific? A A* grammar) b) - (and (more-specific? A* A grammar) a)))] - [else #f])) - - (: all-depends (edge -> (Listof edge))) - (define (all-depends E) - (let ([es (hash-ref chart-depend E (λ () '()))]) - (append es (apply append (map all-depends es))))) - - (: assoc/prec-chart-check! - (edge (Listof edge) -> (Pairof (Setof edge) (Listof edge)))) - (define (assoc/prec-chart-check! e c) - (let chart-check ([ret #f] - [cres (set)] - [c c]) - (if (null? c) - (cons (if ret (set-add cres e) cres) (chart->list chart)) - (let ([f (car c)]) - (let ([a1 (assoc-check? e f)] - [p1 (prec-check? e f)]) - (cond [(or (eq? f a1) (eq? f p1)) - (let ([deps (set-add (list->set (all-depends f)) f)]) - (remove-from-chart! f 'cc) - (chart-check ret (set-union cres deps) (cdr c)))] - [(or (eq? e a1) (eq? e p1)) - (chart-check #t cres (cdr c))] - [else (chart-check ret cres (cdr c))])))))) - - (: spec-chart-check! - (edge (Listof edge) -> (Pairof (Setof edge) (Listof edge)))) - (define (spec-chart-check! e c) - (: compl? (edge -> Boolean)) - (define (compl? f) - (and (= (edge-start e) (edge-start f)) - (= (edge-end e) (edge-end f)) - (edge-complete? f))) - (let ([c* (chart-filter compl? chart (edge-end e) 'end)]) - (let chart-check ([ret #f] - [cres (set)] - [c* c*]) - (if (null? c*) - (cons (if ret (set-add cres e) cres) (chart->list chart)) - (let* ([f (car c*)] - [s1 (spec-check? e f)]) - (cond [(eq? f s1) - (let ([deps (set-add (list->set (all-depends f)) f)]) - (remove-from-chart! f 'cc*) - (chart-check ret (set-union cres deps) (cdr c*)))] - [(eq? e s1) - (chart-check #t cres (cdr c*))] - [else (chart-check ret cres (cdr c*))])))))) - - (: amb-filter! ((Listof edge) -> (Listof edge))) - (define (amb-filter! edges) - ;; return the list of edges with ambiguous edges removed. - ;; side effect: the aux agenda may be updated when spec? is #t. - (: check-rec - ((edge edge -> (Option edge)) edge (Setof edge) -> (Setof edge))) - (define (check-rec check? e res) - (let check ([ds edges]) - (if (null? ds) - res - (let ([r (check? e (car ds))]) - (if r (set-add res r) (check (cdr ds))))))) - - (: amb-edges - ((edge edge -> (Option edge)) edge -> (Setof edge))) - (define (amb-edges check? e) - (let check ([ds edges] - [as '()] - [e-added? #f]) - (if (null? ds) - (list->set as) - (let ([r (check? e (car ds))]) - (if (and (edge? r) (eq? r e)) - (if e-added? - (check (cdr ds) as e-added?) - (check (cdr ds) (cons r as) #t)) - (if (edge? r) - (check (cdr ds) (cons r as) e-added?) - (check (cdr ds) as e-added?))))))) - - (let ([c (chart->list chart)]) - (let loop ([es edges] - [res (set)] - [ares (set)]) - (if (null? es) - (begin (when trace? - (printf "ADD=~n") - (for ([r edges]) - (unless (set-member? res r) - (printf " ~a~n" (edge->string r)))) - (printf "DEL=~n") - (for-each - (λ (r) - (printf " ~a~n" (edge->string r))) - (set->list res))) - (add-to-aux! (set->list ares) 'amb) - (remove* (set->list res) edges)) - (let ([e (car es)]) - (unless (eq? '⊥ (edge-assoc e)) - (set! res (set-union res (amb-edges assoc-check? e)))) - (unless (eq? '⊥ (edge-prec e)) - (set! res (set-union res (amb-edges prec-check? e)))) - (when (or (not (eq? '⊥ (edge-assoc e))) - (integer? (edge-prec e))) - (let ([cc (assoc/prec-chart-check! e c)]) - (set! res (set-union res (car cc))) - (set! c (cdr cc)))) - (when (parser-ops-spec? ops) - (let ([as (amb-edges spec-check? e)]) - (set! res (set-union res as)) - (add-to-aux! (set->list as) 'amb-amb)) - (let ([cc (spec-chart-check! e c)]) - (set! res (set-union res (car cc))) - (set! ares (set-union ares (car cc))) - (set! c (cdr cc)))) - (loop (cdr es) res ares)))))) - - (when trace? - (printf "agenda=~n") - (for ([a agenda]) - (pretty-print (agenda-state-edges a)))) - (let loop () - (let ([S (grammar-start grammar)]) - (match-let ([(agenda-state edges aux hook) (car agenda)]) - (if (null? edges) - (if (null? (cdr agenda)) - (if (or (chart-has-parse? chart S) (null? aux)) - (hook) - (let ([next (agenda-state edges (cdr aux) hook)] - [es (car aux)] [c (chart->list chart)]) - (set! agenda (cons next (cdr agenda))) - (let check-aux ([es es] [c c]) - (unless (null? es) - (let* ([e (car es)] - [cc (assoc/prec-chart-check! e c)]) - (unless (set-member? (car cc) e) - (when trace? (printf "AUX POP:~n ") - (printf "(~a)~n " (edge->string e))) - (process-edge! e)) - (check-aux (cdr es) (cdr cc))))) - (loop))) - (begin (set! agenda (cdr agenda)) - (hook) - (loop))) - ;; update aux variable because amb-filter! may change it - (let* ([es (amb-filter! edges)] - [aux (agenda-state-aux (car agenda))] - [next (agenda-state '() aux hook)]) - (set! agenda (cons next (cdr agenda))) - (for-each process-edge! es) - (loop))))))) - -(: initial-chart ((Vectorof token) Boolean grammar -> Chart)) -(define (initial-chart tokens top-down? G) - (if top-down? - (td-initial-chart tokens G) - (bu-initial-chart tokens G))) - -(: initial-agenda ((Vectorof token) grammar LHS Boolean -> (Listof edge))) -(define (initial-agenda tokens grammar S top-down?) - (if top-down? - (td-initial-agenda grammar S) - (bu-initial-agenda tokens grammar))) - -(: td-initial-chart ((Vectorof token) grammar -> Chart)) -(define (td-initial-chart tokens G) - (let ([start (make-vector (+ 1 (vector-length tokens)) '())] - [end (make-vector (+ 1 (vector-length tokens)) '())]) - (do ([i 0 (+ i 1)]) - ((= i (vector-length tokens)) (cons start end)) - (let* ([tok (vector-ref tokens i)] - [val (token-value tok)] - [j (+ i 1)] - [src (cons (grammar-id G) (string->symbol val))] - [e (edge i j val '() (list tok) '() '⊥ '⊥ (make-hash) #f src)]) - (vector-set! start (edge-start e) (list e)) - (vector-set! end (edge-end e) (list e)))))) - -(: td-initial-agenda (grammar LHS -> (Listof edge))) -(define (td-initial-agenda G S) - (let ([src (cons (grammar-id G) 'start)]) - (list (edge 0 0 'S* '() '() `(,S) '⊥ '⊥ (make-hash) #f src)))) - -(: bu-initial-chart ((Vectorof token) grammar -> Chart)) -(define (bu-initial-chart tokens G) - (let ([start (make-vector (+ 1 (vector-length tokens)) '())] - [end (make-vector (+ 1 (vector-length tokens)) '())]) - (do ([i 0 (+ i 1)]) - ((= i (vector-length tokens)) (cons start end)) - (vector-set! start i '()) - (vector-set! end (+ i 1) '())))) - -(: bu-initial-agenda ((Vectorof token) grammar -> (Listof edge))) -(define (bu-initial-agenda tokens G) - (let loop ([agenda '()] [i 0] [j 0]) - (if (= i (vector-length tokens)) - (reverse agenda) - (let* ([tok (vector-ref tokens i)] - [val (token-value tok)] - [k (+ j 1)] - [src (cons (grammar-id G) (string->symbol val))] - [e (edge j k val '() (list tok) '() '⊥ '⊥ (make-hash) #f src)]) - (loop (cons e agenda) (+ i 1) (+ j 1)))))) - -(: param-subst - (LHS (Listof Term) (Listof Edge-Term) (Listof Term) - (HashTable LHS Any) -> LHS)) -(define (param-subst A left found right vars) - (or (and (null? left) (null? right) - (let ([lhs (lookup vars A)]) - (and (rule-lhs? lhs) (not (string? lhs)) lhs))) - A)) - -(: lexical? (edge -> Boolean)) -(define (lexical? E) - (and (edge-complete? E) - (not (edge-code E)) - (list1? (edge-found E)) - (token? (car (edge-found E))))) - -(: parsed-lexical? (edge -> Boolean)) -(define (parsed-lexical? E) - (and (edge-complete? E) - (not (edge-code E)) - (list1? (edge-found E)) - (let ([p (car (edge-found E))]) - (and (pair? p) - (string? (car p)) - (token? (cdr p)))))) - -(: compl-edge (edge -> (Listof Edge-Term))) -(define (compl-edge E) - (or (and (lexical? E) - (let ([t (car (edge-found E))]) - (and (token? t) - (list (cons (edge-lhs E) t))))) - (or (and (parsed-lexical? E) - (let ([p (car (edge-found E))]) - (and (pair? p) - (token? (cdr p)) - (list (cons (edge-lhs E) (cdr p)))))) - (list E)))) - -(: should-expand? (LHS grammar -> Boolean)) -(define (should-expand? x grammar) - (or (and (string? x) - (is-derivation? x grammar)) - (and (rule-lhs? x) - (not (string? x))))) - -(: chart-filter - ((edge -> Boolean) Chart Integer (U 'start 'end) -> (Listof edge))) -(define (chart-filter pred chart j pt) - ;; pt is whether j is the start or end of an edge - (if (eq? 'start pt) - (filter pred (vector-ref (car chart) j)) - (filter pred (vector-ref (cdr chart) j)))) - -(: chart-text (Integer Chart -> String)) -(define (chart-text i chart) - (match (chart-filter lexical? chart i 'start) - [(list (edge i j A '() (list (? token? t)) '() _ _ _ _ _)) - (token-value t)] - ['() (error "no text in chart at" i)] - [_ (error "ambiguous text in chart at" i)])) - -(: chart->list (Chart -> (Listof edge))) -(define (chart->list chart) - (apply append (vector->list (car chart)))) - -(: edge-is-parse? (edge Integer LHS -> Boolean)) -(define (edge-is-parse? E n S) - (and (edge-complete? E) - (equal? S (edge-lhs E)) - (= n (edge-end E)) - (zero? (edge-start E)))) - -(: chart-has-parse? (Chart LHS -> Boolean)) -(define (chart-has-parse? chart S) - (let ([n (- (vector-length (cdr chart)) 1)]) - (not (null? (filter (λ (e) - (edge-is-parse? e n S)) - (vector-ref (cdr chart) n)))))) - -(: parses - ((Vectorof token) grammar (edge (Listof edge) -> (Listof edge)) LHS - parser-ops -> (Listof edge))) -(define (parses tokens grammar enqueue S ops) - (let* ([ops2 (parser-ops (parser-ops-init-state ops) #t - (parser-ops-left? ops) - (parser-ops-top-down? ops) - (parser-ops-spec? ops) - (parser-ops-trace? ops) - (parser-ops-report? ops))] - [s (chart-parse tokens grammar enqueue S ops2)]) - (if (parser-state? s) - (chart->parses (parser-state-chart s) S) - (error "parses: expected state, got" s)))) - -(: chart->parses (Chart LHS -> (Listof edge))) -(define (chart->parses chart S) - (define trees - (filter (λ (e) - (and (edge-complete? e) - (equal? S (edge-lhs e)) - (zero? (edge-start e)))) - (vector-ref (cdr chart) (- (vector-length (cdr chart)) 1)))) - (when (null? trees) - (let loop ([es (chart-filter - (λ (e) - (and (equal? S (edge-lhs e)) - (edge-incomplete? e) - (not (null? (edge-right e))))) - chart 0 'start)] - [errs '()]) - (if (null? es) - (error 'syntax-error "~a error~a~a" - (length errs) - (if (list1? errs) "" "s") - (with-output-to-string - (λ () - (for ([e errs]) - (printf "\n~a" e))))) - (let* ([e (car es)] - [t (get-last-token e)]) - (match (chart-filter lexical? chart (edge-end e) 'start) - [(list (edge i j A '() (list (? token? u)) '() _ _ _ _ _)) - (if (token? t) - (loop - (cdr es) - (cons - (format - "~a:~a:~a: Expected ~a, but got \"~a\"" - (token-source u) - (token-line u) - (token-column u) - (car (edge-right e)) - (token-value u)) - errs)) - (loop (cdr es) errs))] - [_ - (if (token? t) - (loop - (cdr es) - (cons (format "~a:~a:~a: Expected ~a after \"~a\"" - (token-source t) - (token-line t) - (token-column t) - (car (edge-right e)) - (token-value t)) - errs)) - (loop (cdr es) errs))]))))) - trees) - -(: report ((HashTable LHS Integer) -> Void)) -(define (report stats) - (let ([t 0] - [r '(process-edge! ffr pred-td close-rec bfr pred-bu scan-bu)]) - (hash-for-each stats - (λ (k v) - (when (member k r) - (set! t (+ t v))) - #;(printf "~a => ~a~n" k v))) - (printf " edges=~a" t))) - -(: log-trace (Any Any -> Void)) -(define (log-trace msg E) - (printf "~a: ~a~n" msg (edge->string E))) diff --git a/src/es.rkt b/src/es.rkt deleted file mode 100644 index 126cd88..0000000 --- a/src/es.rkt +++ /dev/null @@ -1,1261 +0,0 @@ -;;;;;; es.rkt - Extensible Syntax. -*- Mode: Racket -*- -;;;;;; Author: Erik Silkensen -;;;;;; Version: 3 Sep 2012 - -#lang typed/racket/no-check - -(require - "bidi-edge.rkt" - "grammar.rkt" - "chart-parser.rkt" - "lexer.rkt" - "utils.rkt") - -(provide parse-file/island parse-file/td-earley parse-file/bu-earley - parse-file compile-file test *program*) - -(define *def-reserved* '("forall" "module" "types")) -(define *use-reserved* '("declare" "import")) - -(define-grammar *program* - [Program ::= (Import Body)] - [Import ::= ("import" NameList ";")] - [Body ::= (Text+) (Declare) (Scope)] - [Declare ::= (IDeclare (? Body))] - [IDeclare ::= ((? Text+) "declare" Text+ "{" Body "}")] - [Scope ::= (IScope (? Body))] - [IScope ::= ((? Text+) "{" Body "}")] - [NameList ::= (*Name) (*Name "," NameList)] - [*Name ::= (,(match-token #rx"^[a-zA-Z][a-zA-Z0-9_>-]*$" *use-reserved*))] - [Text ::= (,(match-token #rx"^[^{}]+$" *use-reserved*))]) - -(define-grammar *module-0* - [Module ::= ("module" *Name "{" (? Text+) Types Text+) - ("module" *Name "{" Text+)] - [Types ::= ("types" "{" Rule+ "}")] - [Rule ::= (ParamRule) (BasicRule) (TypeRule)] - [ParamRule ::= ("forall" *Name+ "." NonParamRule)] - [NonParamRule ::= (BasicRule) (TypeRule)] - [BasicRule ::= (Type "::=" Expression ";")] - [Expression ::= (Term+ (? Attr)) (Term+ (? Attr) "|" Expression)] - [Term ::= (Type) (String) (RegExp)] - [Attr ::= ("[" Attrs "]")] - [Attrs ::= (Assoc) (Prec) (Assoc Prec)] - [TypeRule ::= (Signature "==" SExp+ ";")] - [Signature ::= (BasicSignature)] - [BasicSignature ::= (Type "::=" Expression/Binding)] - [Expression/Binding ::= (Term/Binding+ (? Attr))] - [Term/Binding ::= (Term) (Binding)] - [Binding ::= (*Name ":" Type)] - [Type ::= (*Name)] - [*Name ::= (,(match-token #rx"^[a-zA-Z][a-zA-Z0-9_>-]*$" *def-reserved*))] - [SExp ::= (,(match-token #rx"^[^;]+$" *def-reserved*))] - [Assoc ::= (,(match-token #rx"(left)|(right)"))] - [Prec ::= (#rx"^[0-9]+$")] - [String ::= (#rx"^[\"][^\"]+[\"]$")] - [RegExp ::= (#rx"^#[rp]x\"(.*)\"$")] - [Text ::= (,(match-token #rx"^.*$" '("types")))]) - -(: module-grammar ((Listof String) -> grammar)) -(define (module-grammar *types*) - (define match-name (mk-match-name *types*)) - (define-grammar *module* - [Module ::= ("module" *Name "{" Rule+ "}")] - [Rule ::= (ParamRule) (BasicRule) (ScopeRule) (FunRule) (MacRule)] - [ParamRule ::= ("forall" *Name+ "." NonParamRule)] - [NonParamRule ::= (BasicRule) (ScopeRule) (FunRule) (MacRule)] - [BasicRule ::= (Type "::=" Expression ";")] - [Expression ::= (Term+ (? Attr)) (Term+ (? Attr) "|" Expression)] - [Term ::= (Type) (String) (RegExp)] - [Attr ::= ("[" Attrs "]")] - [Attrs ::= (Assoc) (Prec) (Assoc Prec)] - [FunRule ::= (Signature "=" SExp+ ";")] - [MacRule ::= (Signature "=>" SExp+ ";")] - [TypeRule ::= (Signature "==" SExp+ ";")] - [Signature ::= (BasicSignature) (ScopeSignature)] - [BasicSignature ::= (Type "::=" Expression/Binding)] - [ScopeSignature ::= (Type "::=" Term/Binding+ ScopeDef)] - [ScopeDef ::= ("{" Binding+ ";" Term/Binding+ "}" (? String))] - [ScopeRule ::= (ScopeSignature ";")] - [Expression/Binding ::= (Term/Binding+ (? Attr))] - [Term/Binding ::= (Term) (Binding)] - [Binding ::= (*Name ":" Type)] - [Type ::= (*Name) ,TypeParen] - [*Name ::= (,(match-name #rx"^[a-zA-Z][a-zA-Z0-9_>-]*$" *def-reserved*))] - [SExp ::= (,(match-token #rx"^[^;]+$" *def-reserved*))] - [Assoc ::= (,(match-token #rx"(left)|(right)"))] - [Prec ::= (#rx"^[0-9]+$")] - [String ::= (#rx"^[\"][^\"]+[\"]$")] - [RegExp ::= (#rx"^#[rp]x\"(.*)\"$")]) - *module*) - -(: declare-grammar ((Option grammar) (Listof String) -> grammar)) -(define (declare-grammar G *types*) - (define match-name (mk-match-name *types*)) - (define-grammar *declare* - [BindingList ::= (Binding) (Binding "," BindingList)] - [Binding ::= (*Name ":" Type)] - [Type ::= (*Name) ,TypeParen] - [*Name ::= (,(match-name #rx"^[a-zA-Z][a-zA-Z0-9_>-]*$" *use-reserved*))]) - (if (grammar? G) - (grammar-union *declare* G) - *declare*)) - -(: body-grammar - (grammar (Option grammar) (Option (Listof String)) -> grammar)) -(define (body-grammar G T *types*) - (define match-name (mk-match-name (or *types* '()))) - (define-grammar *base-type* - [Type ::= (*Name) ,TypeParen] - [*Name ::= (,(match-name #rx"^[a-zA-Z][a-zA-Z0-9_>-]*$" *use-reserved*))]) - (grammar-union G (if (grammar? T) - (grammar-union *base-type* T) - *base-type*))) - -(define TypeParen - (let ([rhs '("(" ("T" . Type) ")")] - [vars (make-hash)] - [type '(T)] - [proc (λ: ([args : (Listof Any)]) - (eval `(let-syntax ([eval (syntax-rules () - [(_ T) 'T])]) - (eval ,@args)) - (make-base-namespace)))]) - (hash-set! vars "T" '(#f . Type)) - (half-rule rhs '⊥ '⊥ vars (cons type proc)))) - -(: mk-match-name - ((Listof String) -> - (case-> [Regexp -> (String -> (Option String))] - [Regexp (Listof String) -> (String -> (Option String))]))) -(define (mk-match-name *types*) - (let ([mn (λ: ([regexp : Regexp] [except : (Listof String)]) - (λ: ([str : String]) - (and (regexp-match regexp str) - (not (member str except)) - (let: loop : (Option String) - ([types : (Listof String) *types*]) - (or (and (null? types) str) - (let ([t (car types)]) - (and (if (regexp? t) - (not (regexp-match t str)) - (not (equal? t str))) - (loop (cdr types)))))))))]) - (case-lambda: - [([regexp : Regexp]) - (mn regexp '())] - [([regexp : Regexp] [except : (Listof String)]) - (mn regexp except)]))) - -;; set at runtime: whether to compile or parse, i.e., -;; if a grammar rule has an implementation, compile -(define: *compile-mode?* : Boolean #f) - -;; whether to parse bidirectionally, i.e., -;; allow symbols to the left of an edge's first dot -(define: *bidi-mode?* : Boolean #t) - -;; whether to parse bottom-up, i.e., -;; #t => agenda_0 = tokens; #f => chart_0 = tokens -(define: *bottom-up-mode?* : Boolean #t) - -;; whether to print a trace when parsing the program -(define: *inner-trace?* : Boolean #f) - -;; whether to report the parse time and edge count -(define: *inner-report?* : Boolean #f) - -;; whether or not to include terminals in AST, e.g., -;; A ::= B "+" C; => (A (B "+" C)) or (A (B C)) -(define: *edge->ast-terminals?* : Boolean #f) - -(define-type Env (Rec E (U #f (Pairof (HashTable String Any) E)))) -(define-predicate env? Env) - -(struct: es-ops - ([state : (Option parser-state)] - [ret-state? : Boolean] - [env : Env] - [code? : Boolean] - [types : (Option (Pairof grammar (Listof String)))])) - -(: compile-file - (case-> [String -> Void] - [String Boolean -> Void] - [String Boolean Boolean -> Void])) -(define compile-file - (let ([cf (λ: ([filename : String] [trace? : Boolean] [time? : Boolean]) - (let ([out (format "~a.rkt" (filename-base filename))] - [ps (parse-file/bu-earley filename trace? time? #t)]) - (cond [(null? ps) (error "parse error")] - [(list1? ps) - (with-output-to-file out - (λ () - (printf "#lang typed/racket/no-check~n") - (let ([p (car ps)]) - (when (list? p) - (for-each (λ (e) (printf "~s~n" e)) p)))) - #:exists 'replace)] - [else (error "parse ambiguous")])))]) - (case-lambda: - [([filename : String]) - (cf filename #f #f)] - [([filename : String] [trace? : Boolean]) - (cf filename trace? #f)] - [([filename : String] [trace? : Boolean] [time? : Boolean]) - (cf filename trace? time?)]))) - -(define-syntax-rule (mk-parse-file body ...) - (let ([pf (λ: ([filename : String] [trace? : Boolean] [time? : Boolean] - [compile? : Boolean]) - body ... - (parse-file filename trace? time? compile?))]) - (case-lambda: - [([filename : String]) - (pf filename #f #f #f)] - [([filename : String] [trace? : Boolean]) - (pf filename trace? #f #f)] - [([filename : String] [trace? : Boolean] [time? : Boolean]) - (pf filename trace? time? #f)] - [([filename : String] [trace? : Boolean] [time? : Boolean] - [compile? : Boolean]) - (pf filename trace? time? compile?)]))) - -(: parse-file/island - (case-> [String -> (U (Listof Sexp) (Listof edge))] - [String Boolean -> (U (Listof Sexp) (Listof edge))] - [String Boolean Boolean -> (U (Listof Sexp) (Listof edge))] - [String Boolean Boolean Boolean -> (U (Listof Sexp) (Listof edge))])) -(define parse-file/island - (mk-parse-file - (set! *bidi-mode?* #t) - (set! *bottom-up-mode?* #t))) - -(: parse-file/bu-earley - (case-> [String -> (U (Listof Sexp) (Listof edge))] - [String Boolean -> (U (Listof Sexp) (Listof edge))] - [String Boolean Boolean -> (U (Listof Sexp) (Listof edge))] - [String Boolean Boolean Boolean -> (U (Listof Sexp) (Listof edge))])) -(define parse-file/bu-earley - (mk-parse-file - (set! *bidi-mode?* #f) - (set! *bottom-up-mode?* #t))) - -(: parse-file/td-earley - (case-> [String -> (U (Listof Sexp) (Listof edge))] - [String Boolean -> (U (Listof Sexp) (Listof edge))] - [String Boolean Boolean -> (U (Listof Sexp) (Listof edge))] - [String Boolean Boolean Boolean -> (U (Listof Sexp) (Listof edge))])) -(define parse-file/td-earley - (mk-parse-file - (set! *bidi-mode?* #f) - (set! *bottom-up-mode?* #f))) - -(: parse-file - (case-> [String -> (U (Listof Sexp) (Listof edge))] - [String Boolean -> (U (Listof Sexp) (Listof edge))] - [String Boolean Boolean -> (U (Listof Sexp) (Listof edge))] - [String Boolean Boolean Boolean -> (U (Listof Sexp) (Listof edge))])) -(define parse-file - (let ([pf (λ: ([filename : String] [trace? : Boolean] [time? : Boolean] - [compile? : Boolean]) - (set! *compile-mode?* compile?) - (set! *inner-trace?* trace?) - (set! *inner-report?* time?) - (let* ([tokens (tokenize-file filename)] - [ops (parser-ops #f #f #f #t #f #f #f)] - [ps (parses tokens *program* cons 'Program ops)]) - (cond [(null? ps) (error "surface syntax error!")] - [(list1? ps) - (parse-program (car ps) filename)] - [else - (error (format "surface syntax ambiguous! (~a)" - (length ps)))])))]) - (case-lambda: - [([filename : String]) - (pf filename #f #f #f)] - [([filename : String] [trace? : Boolean]) - (pf filename trace? #f #f)] - [([filename : String] [trace? : Boolean] [time? : Boolean]) - (pf filename trace? time? #f)] - [([filename : String] [trace? : Boolean] [time? : Boolean] - [compile? : Boolean]) - (pf filename trace? time? compile?)]))) - -(: parse-file/module - (String -> (List grammar (Option (Pairof grammar (Listof String)))))) -(define (parse-file/module filename) - (let* ([tokens (tokenize-file filename)] - [ops (parser-ops #f #f #f #t #f #f #f)] - [ps (parses tokens *module-0* cons (grammar-start *module-0*) ops)]) - (cond - [(null? ps) - (error (format "module ~a syntax error!" filename))] - [(list1? ps) - (let-values ([(G H) (parse-module-0 (car ps) filename)]) - (list G H))] - [else - (error (format "module ~a syntax ambiguous (~a)!" - filename (length ps)))]))) - -(: parse-program (edge String -> (U (Listof Sexp) (Listof edge)))) -(define (parse-program E filename) - ;; E : [Program ::= (Import Body)] - (match E - [(edge-complete 'Program (list (? edge? Import) (? edge? Body))) - (let* ([GT (parse-import Import filename)] - [T (and (second GT) (car (second GT)))] - [*types* (and (second GT) (or (cdr (second GT)) '()))] - [G (body-grammar (first GT) T *types*)] - [ops (es-ops #f #f #f #t (second GT))] - [ps (parse-body Body G ops)]) - (if (parser-state? ps) - (error "expected Sexp:" ps) - ps))])) - -(: parse-import - (edge String -> (List grammar (Option (Pairof grammar (Listof String)))))) -(define (parse-import E filename) - ;; E : [Import ::= ("import" NameList ";")] - (match E - [(edge-complete 'Import (list _ (? edge? NameList) _)) - (let* ([dir (filename-dir filename)] - [parse-name - (λ: ([p : Edge-Term]) - (match p - [(cons '*Name (? token? t)) (token-value t)]))] - [names (parse-rec NameList parse-name first (mk-rec third))] - [mods (map (λ (n) (format "~a~a.es" dir n)) names)]) - (foldl - (λ: ([x : (List grammar (Option (Pairof grammar (Listof String))))] - [y : (List grammar (Option (Pairof grammar (Listof String))))]) - (let ([G (grammar-union (first y) (first x))]) - (if (second x) - (let ([H (car (second x))] [T (cdr (second x))]) - (if (second y) - (list G (cons (grammar-union (car (second y)) H) - (append (cdr (second y)) T))) - (list G (second x)))) - (list G (second y))))) - (list (mk-grammar '() 'G0) #f) - (map parse-file/module mods)))])) - -(: parse-body - (edge grammar es-ops -> (U parser-state (Listof Sexp) (Listof edge)))) -(define (parse-body E G ops) - ;; E : [Body ::= Text+ Declare Scope] - (match E - [(edge-complete 'Body (list (? edge? e))) - (let ([state (es-ops-state ops)] - [ret-state? (es-ops-ret-state? ops)] - [env (es-ops-env ops)] - [code? (es-ops-code? ops)] - [T (es-ops-types ops)]) - (case (edge-lhs e) - [(Text+) - (let ([s1 (next-state state E G env #f)]) - (if *compile-mode?* - (compile-text e G s1 ret-state? code?) - (parse-text e G s1 ret-state? #t)))] - [(Declare) (parse-declare e G ops)] - [(Scope) (parse-scope e G ops)] - [else (error "parse-body: unexpected:" (edge-lhs e))]))])) - -(: parse-declare - (edge grammar es-ops -> (U parser-state (Listof Sexp) (Listof edge)))) -(define (parse-declare E G ops) - ;; E : [Declare ::= (IDeclare (? Body))] - (let ([decl (first (edge-found E))] - [state (es-ops-state ops)] - [ret-state? (es-ops-ret-state? ops)] - [env (es-ops-env ops)] - [code? (es-ops-code? ops)] - [T (es-ops-types ops)]) - (let-values ([(id H) (parse-ideclare decl G (es-ops state #t env #f T))]) - (cond - [(parser-state? id) - (state/undeclare! id H) - (if (list1? (edge-found E)) - (cond [(pair? env) id] - [*compile-mode?* (compile-state id G)] - [ret-state? id] - [else (close-state id G)]) - (let* ([bod (second (edge-found E))] - [s1 (next-state id bod G env #f)]) - (parse-body bod G (es-ops s1 ret-state? env code? T))))] - [else (error "expected state:" id)])))) - -(: parse-ideclare - (edge grammar es-ops -> - (Values (U parser-state (Listof Sexp) (Listof edge)) grammar))) -(define (parse-ideclare E G ops) - ;; E : [IDeclare ::= ((? Text+) "declare" Text+ "{" Body "}")] - (define (bindings) - (let* ([words (extract-text - (if (listn? 6 (edge-found E)) - (third (edge-found E)) - (second (edge-found E))))] - [T (es-ops-types ops)] - [D (declare-grammar (if T (car T) #f) (if T (cdr T) '()))] - [ps (parse-words words D #f #f #f)]) - (if (list? ps) - (car ps) - (error (format "syntax error: declare~a" - (if (null? ps) "" " ambiguous")))))) - (define (body) - (if (listn? 6 (edge-found E)) - (fifth (edge-found E)) - (fourth (edge-found E)))) - (define (first-state) - (if (listn? 6 (edge-found E)) - (let* ([pre (first (edge-found E))] - [s0 (next-state (es-ops-state ops) pre G (es-ops-env ops) #f)]) - (if *compile-mode?* - (compile-text pre G s0 #t #f) - (parse-text pre G s0 #t #f))) - (es-ops-state ops))) - (let loop ([bs (parse-binding-list (bindings))] - [rules '()]) - (if (null? bs) - (let* ([H (mk-grammar rules 'H)] - [I (grammar-union G H)] - [ret-state? (es-ops-ret-state? ops)] - [env (es-ops-env ops)] - [code? (es-ops-code? ops)] - [s1 (next-state/declare (first-state) (body) I H env #f)] - [ops-b (es-ops s1 ret-state? env code? #f)]) - (values (parse-body (body) I ops-b) H)) - (match (car bs) - [(cons (? string? rhs) (? rule-lhs? lhs)) - (loop (cdr bs) (cons `(,lhs ::= (,rhs)) rules))])))) - -(: parse-scope - (edge grammar es-ops -> (U parser-state (Listof Sexp) (Listof edge)))) -(define (parse-scope E G ops) - ;; E : [Scope ::= (IScope (? Body))] - (let* ([iscope (first (edge-found E))] - [state (es-ops-state ops)] - [ret-state? (es-ops-ret-state? ops)] - [env (es-ops-env ops)] - [code? (es-ops-code? ops)] - [T (es-ops-types ops)] - [ops-is (es-ops state #t env code? T)] - [is (parse-iscope iscope G ops-is)]) - (if (parser-state? is) - (if (list1? (edge-found E)) - (cond [(pair? env) is] - [*compile-mode?* (compile-state is G)] - [ret-state? is] - [else (close-state is G)]) - (let ([ops (es-ops is (es-ops-ret-state? ops) env code? T)]) - (parse-body (second (edge-found E)) G ops))) - (error "expected parser-state:" is)))) - -(: parse-iscope - (edge grammar es-ops -> (U parser-state (Listof Sexp) (Listof edge)))) -(define (parse-iscope E G ops) - ;; E : [IScope ::= ((? Text+) "{" Body "}")]) - (define open-scope - (if (list4? (edge-found E)) - (match (second (edge-found E)) - [(cons _ (? token? t)) (vector t)]) - (match (first (edge-found E)) - [(cons _ (? token? t)) (vector t)]))) - (define close-scope - (match (last (edge-found E)) - [(cons _ (? token? t)) (vector t)])) - (define body - (if (list4? (edge-found E)) - (third (edge-found E)) - (second (edge-found E)))) - (define (first-state) - (let ([state (es-ops-state ops)]) - (if (list4? (edge-found E)) - (let* ([pre (extract-text (first (edge-found E)))] - [env (es-ops-env ops)] - [s0 (next-state-tokens state pre G env #t)]) - (parse-words pre G s0 #t #t)) - state))) - (: first-edges ((Option parser-state) -> (Listof edge))) - (define (first-edges fs) - (: pre-scope? (edge -> Boolean)) - (define (pre-scope? e) - (and (edge-incomplete? e) - (null? (edge-left e)) - (equal? "{" (first (edge-right e))))) - (if (parser-state? fs) - (let ([end (- (vector-length (cdr (parser-state-chart fs))) 1)]) - (chart-filter pre-scope? (parser-state-chart fs) end 'end)) - '())) - (let* ([s1 (first-state)] - [s2 (next-state-tokens s1 open-scope G #f #f)] - [s3 (parse-words open-scope G s2 #t #t)] - [env (make-env (es-ops-env ops) (map edge-vars (first-edges s1)))] - [ops-b (es-ops s3 #t env #f #f)] - [s4 (parse-body body G ops-b)] - [s5 (next-state-tokens s4 close-scope G #f #f)]) - (parse-words close-scope G s5 (es-ops-ret-state? ops) #t))) - -(: parse-text - (edge grammar (Option parser-state) Boolean Boolean -> - (U parser-state (Listof Sexp) (Listof edge)))) -(define (parse-text E G state ret-state? ast?) - ;; E : [Text+ ::= (Text (? Text+))] - (parse-words (extract-text E) G state ret-state? ast?)) - -(: parse-words - ((Vectorof token) grammar (Option parser-state) Boolean Boolean -> - (U parser-state (Listof Sexp) (Listof edge)))) -(define (parse-words tokens G state ret-state? ast?) - (let ([S (grammar-start G)] - [enqueue (λ: ([e : edge] [a : (Listof edge)]) (append a (list e)))] - [left? *bidi-mode?*] [top-down? (not *bottom-up-mode?*)] - [spec? #t] [trace? *inner-trace?*] [report? *inner-report?*]) - (when trace? (pretty-print G)) - (if ret-state? - (let ([ops (parser-ops state #t left? top-down? spec? trace? report?)]) - (chart-parse tokens G enqueue S ops)) - (let* ([ops (parser-ops state #f left? top-down? spec? trace? report?)] - [edges (parses tokens G enqueue S ops)]) - (if ast? - (map (λ: ([e : edge]) (edge->ast e *edge->ast-terminals?*)) - edges) - edges))))) - -(: compile-text - (edge grammar (Option parser-state) Boolean Boolean -> - (U parser-state (Listof Sexp) (Listof edge)))) -(define (compile-text E G state ret-state? code?) - ;; E : [Text+ ::= (Text (? Text+))] - (let ([code-state (parse-words (extract-text E) G state #t #t)]) - (if code? - (compile-state code-state G) - code-state))) - -(: compile-state (parser-state grammar -> (U (Listof Sexp) (Listof edge)))) -(define (compile-state state G) - (match-let ([(cons args fdefs) (gen-fun-defs G)]) - (let loop ([i 0] [ws '()] [fail? #t]) - (if (= i (- (vector-length (car (parser-state-chart state))) 1)) - (if fail? - (error "compile error! no code") - (let ([body (with-input-from-string - (format "(begin ~a)" - (string-join (reverse ws) " ")) - read)]) - (list (append (apply append fdefs) - (list body))))) - (let* ([chart (parser-state-chart state)] - [es (chart-filter (fun-parse? args) chart i 'start)]) - (if (null? es) - (let ([w (chart-text i chart)]) - (loop (+ i 1) (cons w ws) fail?)) - (loop (edge-end (car es)) - (let ([code (compile-code (car es) args)]) - (append (reverse code) ws)) - #f))))))) - -(: compile-code - ((U Edge-Term Term) (HashTable Symbol (Option (Listof Symbol))) -> - (Listof String))) -(define (compile-code c args) - (: mk-args (Symbol -> (Listof String))) - (define (mk-args id) - (let ([lst (hash-ref args id)]) - (if lst - (map symbol->string lst) - (error "expected (Listof Symbol):" lst)))) - (cond [(edge? c) - (let ([vars (edge-vars c)] - [id (cdr (edge-src c))]) - (match (hash-ref args id (λ () #f)) - [(? list? formals) - (let loop ([fs (map symbol->string formals)] - [ss '()]) - (if (null? fs) - `("(" ,(symbol->string id) ,@ss ")") - (let* ([f (car fs)] - [k (if (hash-has-key? vars f) f - (string->symbol f))]) - (match (hash-ref vars k) - [(or (? rule-lhs? sub-code) - (list (cons sub-code _))) - (if (or (edge? sub-code) - (sexpr? sub-code) - (string? sub-code)) - (loop (cdr fs) - (append ss (compile-code sub-code args))) - (error "compile-code unexpected:" sub-code))]))))] - [else (list (unparse (if (eq? 'Type (edge-lhs c)) - (parse-type c) c) " "))]))] - [else (list (unparse c " "))])) - -(: gen-fun-defs - (grammar -> (Pairof (HashTable Symbol (Option (Listof Symbol))) - (Listof (Listof Sexp))))) -(define (gen-fun-defs G) - ;; returns (cons args defs) where args maps rule ids to argument lists - ;; and defs is a list of function and macro defns - (let* ([args (make-hash)] - [all-rules (expand-rules (grammar-rules G))] - [defs (map (λ: ([r : rule]) - (let ([id (cdr (rule-src r))] - [code (rule-code r)]) - ;; code = (type . defn), type = '() for macros - ;; defn = # - ;; | (lambda formals body) - ;; | (syntax-rules () [(_ pat) exp]) - (cond [(procedure? (cdr code)) ;; type-rule - (hash-set! args id #f) #f] - [(car code) ;; function/macro - (match (cdr code) - [(rule-function formals body) - (hash-set! args id formals) - `((: ,id ,(car code)) - (define ,id ,(cdr code)))] - [(rule-macro pat exp) - (hash-set! args id pat) - `((define-syntax ,id ,(cdr code)))])] - [else (error "gen-fun-defs unexpected:" code)]))) - (filter fun-def? all-rules))]) - (cons args (filter sexp-list? defs)))) - -(define-match-expander rule-function - (syntax-rules () - [(rule-function formals body) - `(λ ,(? symbol-list? formals) ,body)])) - -(define-match-expander rule-macro - (syntax-rules () - [(rule-macro pat exp) - `(syntax-rules () - [,(cons _ (? symbol-list? pat)) ,exp])])) - -(: parse-module-0 - (edge String -> (Values grammar (Option (Pairof grammar (Listof String)))))) -(define (parse-module-0 E filename) - ;; E : [Module ::= ("module" *Name "{" (? Text+) (? Types) Text+)] - (: grammar-words - (-> (Values grammar (Option (Pairof grammar (Listof String))) - (Vectorof token)))) - (define (grammar-words) - (define: start-words : (Vectorof token) - (match (edge-found E) - [(list (cons _ (? token? module)) (cons '*Name (? token? name)) - (cons _ (? token? open-module)) _ ...) - (vector module name open-module)])) - (match (length (edge-found E)) - [6 - (let ([t1 (extract-text (fourth (edge-found E)))] - [T (parse-types (fifth (edge-found E)))] - [t2 (extract-text (sixth (edge-found E)))]) - (values (grammar-union (module-grammar (cdr T)) (car T)) T - (vector-append start-words t1 t2)))] - [5 - (let ([T (parse-types (fourth (edge-found E)))] - [t1 (extract-text (fifth (edge-found E)))]) - (values (grammar-union (module-grammar (cdr T)) (car T)) T - (vector-append start-words t1)))] - [4 - (let ([t1 (extract-text (fourth (edge-found E)))]) - (values (module-grammar '()) #f - (vector-append start-words t1)))])) - (let-values ([(G H words) (grammar-words)]) - (let* ([trace? #f] - [ops (parser-ops #f #f #f #t #f trace? #f)]) - (when trace? (pretty-print G)) - (let ([ps (parses words G cons (grammar-start G) ops)]) - (cond - [(null? ps) (error (format "module-0 ~a syntax error!" filename))] - [(list1? ps) (values (parse-module (car ps)) H)] - [else (error (format "module-0 ~a syntax ambiguous (~a)!" - filename (length ps)))]))))) - -(: parse-types (edge -> (Pairof grammar (Listof String)))) -(define (parse-types E) - ;; E : [Types ::= ("types" "{" Rule+ "}")] - (let ([rules (parse-rule+ (third (edge-found E)))]) - (let split ([R rules] - [rules '()] - [types '()]) - (cond [(null? R) - (cons (mk-grammar (reverse rules) 'Types) types)] - [(lexical-rule? (car R)) - (let ([ts (match (get-lexical-term (car R)) - [(? string? t) (list t)] - [_ '()])]) - (split (cdr R) (cons (car R) rules) (append types ts)))] - [else (split (cdr R) (cons (car R) rules) types)])))) - -(: parse-module (edge -> grammar)) -(define (parse-module E) - ;; E : [Module ::= ("module" *Name "{" Rule+ "}")] - (let ([name (string->symbol (unparse (second (edge-found E))))] - [rules (parse-rule+ (fourth (edge-found E)))]) - (let split ([R rules] [rules '()]) - (if (null? R) - (mk-grammar (reverse rules) name) - (split (cdr R) (cons (car R) rules)))))) - -(: parse-rule (edge -> (Listof Rule-Spec))) -(define (parse-rule E) - ;; E : [Rule ::= ParamRule BasicRule ScopeRule FunRule MacRule TypeRule] - (let ([e (first (edge-found E))]) - (match (edge-lhs e) - ['ParamRule (parse-param-rule e)] - ['BasicRule (parse-basic-rule e '())] - ['ScopeRule (parse-scope-rule e '())] - ['FunRule (parse-fun-rule e '())] - ['MacRule (parse-mac-rule e '())] - ['TypeRule (parse-type-rule e '())]))) - -(: parse-param-rule (edge -> (Listof Rule-Spec))) -(define (parse-param-rule E) - ;; E : [ParamRule ::= ("forall" *Name+ "." NonParamRule)] - ;; where [NonParamRule ::= BasicRule ScopeRule FunRule MacRule] - (: adjust (String -> (Pairof Symbol Any))) - (define (adjust var) (cons (string->symbol var) #f)) - (let* ([*Name+ (second (edge-found E))] - [parse-name - (λ: ([p : Edge-Term]) - (match p - [(cons '*Name (? token? t)) (token-value t)]))] - ;;[(edge-complete '*Name (list (cons _ (? string? n)))) n]))] - [vars (parse-rec *Name+ parse-name first (mk-rec second))] - [tbsrule (fourth (edge-found E))]) - ((match (edge-lhs (first (edge-found tbsrule))) - ['BasicRule parse-basic-rule] - ['ScopeRule parse-scope-rule] - ['FunRule parse-fun-rule] - ['MacRule parse-mac-rule] - ['TypeRule parse-type-rule]) - (first (edge-found tbsrule)) - (map adjust vars)))) - -(: parse-basic-rule (edge (Listof (Pairof Symbol Any)) -> (Listof Rule-Spec))) -(define (parse-basic-rule E vars) - ;; E : [BasicRule ::= (Type "::=" Expression ";")] - (let ([type (parse-type (first (edge-found E)))]) - (map (λ: ([hr : half-rule]) - ;; TODO: make this cleaner somehow - (let ([lhs type] - [rhs (list hr)]) - (cons lhs (cons '::= rhs)))) - (parse-expression (third (edge-found E)) vars)))) - -(: parse-expression (edge (Listof (Pairof LHS Any)) -> (Listof half-rule))) -(define (parse-expression E vars) - ;; E : [Expression ::= (Term+ Attr?) (Term+ Attr? "|" Expression)] - (let loop ([E E] [rs '()]) - (let ([e (parse-term+ (first (edge-found E)))] - [vs (make-hash vars)]) - (cond [(list1? (edge-found E)) - (reverse (cons (half-rule e '⊥ '⊥ vs #f) rs))] - [(list2? (edge-found E)) - (let ([attr (second (edge-found E))]) - (let-values ([(assoc prec) (parse-attr attr)]) - (reverse (cons (half-rule e assoc prec vs #f) rs))))] - [(list3? (edge-found E)) - (let ([F (third (edge-found E))]) - (loop F (cons (half-rule e '⊥ '⊥ vs #f) rs)))] - [else - (let ([attr (second (edge-found E))] - [F (fourth (edge-found E))]) - (let-values ([(assoc prec) (parse-attr attr)]) - (loop F (cons (half-rule e assoc prec vs #f) rs))))])))) - -(: parse-term (Edge-Term -> Term)) -(define (parse-term E) - ;; E : [Term ::= Type String RegExp] or [Type String RegExp] - (let ([t (if (edge? E) (first (edge-found E)) E)]) - (match t - [(? edge? term) - (parse-type term)] - [(cons 'String t) - (let ([s (token-value t)]) - (substring s 1 (- (string-length s) 1)))] - [(cons 'RegExp t) - (let ([s (token-value t)]) - (regexp (substring s 4 (- (string-length s) 1))))] - [_ (error (format "parse-term unexpected: ~a" E))]))) - -(: parse-attr (edge -> (Values Assoc Prec))) -(define (parse-attr E) - ;; E : [Attr ::= "[" Attrs "]"] where - ;; [Attrs ::= Assoc Prec (Assoc Prec)] - (let* ([e (second (edge-found E))] - [fst (first (edge-found e))] - [fst-str (unparse fst)]) - (cond [(list2? (edge-found e)) - (let ([snd-str (unparse (second (edge-found e)))]) - (values (string->symbol fst-str) - (string->number snd-str)))] - [(eq? 'Assoc (car fst)) - (values (string->symbol fst-str) '⊥)] - [else (values '⊥ (string->number fst-str))]))) - -(: parse-fun-rule (edge (Listof (Pairof Symbol Any)) -> (Listof Rule-Spec))) -(define (parse-fun-rule E vars) - ;; E : [FunRule ::= (Signature "=" SExp+ ";")] - (: mk-type (LHS (Listof (Pairof Symbol Any)) -> SExpr)) - (define (mk-type lhs formals) - (let* ([kar (λ: ([p : (Pairof Symbol Any)]) (car p))] - [kdr (λ: ([p : (Pairof Symbol Any)]) - (cdr p))] - [type `(,@(map kdr formals) -> ,lhs)] - [types (list->set (flatten type))] - [var-types (map kar vars)]) - (let close-type ([var-types var-types] - [fvs '()]) - (if (null? var-types) - (or (and (null? fvs) type) - `(All ,(reverse fvs) ,type)) - (let ([var (car var-types)]) - (if (set-member? types var) - (close-type (cdr var-types) (cons var fvs)) - (close-type (cdr var-types) fvs))))))) - (: mk-mk-code - (Sexp -> (LHS (Listof (Pairof Symbol Any)) -> - (U Sexp ((Listof Any) -> Sexp))))) - (define (mk-mk-code body) - (let ([kar (λ: ([p : (Pairof Symbol Any)]) (car p))]) - (λ: ([lhs : LHS] [formals : (Listof (Pairof Symbol Any))]) - `(λ ,(map kar formals) ,body)))) - (parse-rule-action E mk-type mk-mk-code vars)) - -(: parse-mac-rule (edge (Listof (Pairof Symbol Any)) -> (Listof Rule-Spec))) -(define (parse-mac-rule E vars) - ;; E : [MacRule ::= (Signature "=>" SExp+ ";")] - (: mk-type (LHS (Listof (Pairof Symbol Any)) -> SExpr)) - (define (mk-type lhs formals) '()) - (: mk-mk-code - (Sexp -> (LHS (Listof (Pairof Symbol Any)) -> - (U Sexp ((Listof Any) -> Sexp))))) - (define (mk-mk-code body) - (let ([kar (λ: ([p : (Pairof Symbol Any)]) (car p))]) - (λ: ([lhs : LHS] [formals : (Listof (Pairof Symbol Any))]) - (let ([types (map kar vars)]) - `(syntax-rules () - [(_ ,@(map kar formals) ,@types) ,body]))))) - (parse-rule-action E mk-type mk-mk-code vars)) - -;;; parse-type-rule : Edge -> Rule -;; Edge : [TypeRule ::= (Signature "==" SExp+ ";")] -(: parse-type-rule (edge (Listof (Pairof Symbol Any)) -> (Listof Rule-Spec))) -(define (parse-type-rule E vars) - (: mk-type (LHS (Listof (Pairof Symbol Any)) -> SExpr)) - (define (mk-type lhs formals) - (mapcar formals)) - (: mk-mk-code - (Sexp -> (LHS (Listof (Pairof Symbol Any)) -> - (U Sexp ((Listof Any) -> Sexp))))) - (define (mk-mk-code body) - (λ: ([lhs : LHS] [formals : (Listof (Pairof Symbol Any))]) - (λ: ([args : (Listof Any)]) - (eval `(let-syntax ([eval (syntax-rules () - [(_ ,@(mapcar formals)) - ',body])]) - (eval ,@args)) - (make-base-namespace))))) - (parse-rule-action E mk-type mk-mk-code vars)) - -(: parse-rule-action - (edge (LHS (Listof (Pairof Symbol Any)) -> SExpr) - (Sexp -> (LHS (Listof (Pairof Symbol Any)) -> - (U Sexp ((Listof Any) -> Sexp)))) - (Listof (Pairof Symbol Any)) -> (Listof Rule-Spec))) -(define (parse-rule-action E mk-type mk-mk-code vars) - (let ([sig (first (edge-found E))] - [body (parse-sexp+ (third (edge-found E)))]) - (parse-signature sig mk-type (mk-mk-code body) vars))) - -(: parse-signature - (edge (LHS (Listof (Pairof Symbol Any)) -> SExpr) - (LHS (Listof (Pairof Symbol Any)) -> (U Sexp ((Listof Any) -> Sexp))) - (Listof (Pairof Symbol Any)) -> (Listof Rule-Spec))) -(define (parse-signature E mk-type mk-code vars) - ;; E : [Signature ::= BasicSignature ScopeSignature] - (let ([sig (first (edge-found E))]) - ((if (eq? 'BasicSignature (edge-lhs sig)) - parse-basic-signature parse-scope-signature) - sig mk-type mk-code vars))) - -(: parse-basic-signature - (edge (LHS (Listof (Pairof Symbol Any)) -> SExpr) - (LHS (Listof (Pairof Symbol Any)) -> (U Sexp ((Listof Any) -> Sexp))) - (Listof (Pairof Symbol Any)) -> (Listof Rule-Spec))) -(define (parse-basic-signature E mk-type mk-code vars) - ;; E : [BasicSignature ::= (Type "::=" Expression/Binding)] - (match E - [(edge-complete 'BasicSignature (list (? edge? T) _ (? edge? E/B))) - (let-values ([(rhs assoc prec) (parse-expression/binding E/B)]) - (let ([lhs (parse-type T)] - [formals (get-formals rhs)] - [vs (make-hash vars)]) - (for ([var formals]) - (hash-set! vs (symbol->string (car var)) (cons #f (cdr var)))) - (let* ([type (mk-type lhs formals)] - [proc (mk-code lhs formals)] - [code (cons type proc)] - [rhs (list (half-rule rhs assoc prec vs code))]) - (list (cons lhs (cons '::= rhs))))))])) - -(: parse-scope-signature - (edge (LHS (Listof (Pairof Symbol Any)) -> SExpr) - (LHS (Listof (Pairof Symbol Any)) -> (U Sexp ((Listof Any) -> Sexp))) - (Listof (Pairof Symbol Any)) -> (Listof Rule-Spec))) -(define (parse-scope-signature E mk-type mk-code vars) - ;; E : [ScopeSignature ::= (Type "::=" Term/Binding+ ScopeDef)] - (match E - [(edge-complete 'ScopeSignature - (list (? edge? T) _ (? edge? T/B) (? edge? SD))) - (let* ([lhs (parse-type T)] - [ts (parse-term/binding+ T/B)] - [rhs (list (parse-scope-def SD lhs ts mk-type mk-code vars))]) - (list (cons lhs (cons '::= rhs))))])) - -(: parse-scope-def - (edge LHS (Listof Term) - (LHS (Listof (Pairof Symbol Any)) -> SExpr) - (LHS (Listof (Pairof Symbol Any)) -> (U Sexp ((Listof Any) -> Sexp))) - (Listof (Pairof Symbol Any)) -> half-rule)) -(define (parse-scope-def E lhs t/bs mk-type mk-code vars) - ;; E : [ScopeDef ::= ("{" Binding+ ";" Term/Binding+ "}" (? String))] - (let* ([b (parse-binding+ (second (edge-found E)))] - [t/bs2 (parse-term/binding+ (fourth (edge-found E)))] - [formals (append (get-formals t/bs) (get-formals t/bs2))] - [vs (make-hash vars)] - [s (if (listn? 6 (edge-found E)) - (list (sixth (edge-found E))) - '())]) - (for ([var b]) - (let ([p var]) - (hash-set! vs (car p) (cons #f (cdr p))))) - (let ([type (mk-type lhs formals)] - [proc (mk-code lhs formals)] - [rhs `(,@t/bs "{" ,@t/bs2 "}" ,@(map parse-term s))]) - (when (or type proc) - (for ([var formals]) - (let ([key (symbol->string (car var))]) - (unless (hash-has-key? vs key) - (hash-set! vs key (cons #f (cdr var))))))) - (let ([code (cons type proc)]) - (half-rule rhs '⊥ '⊥ vs code))))) - -(: parse-scope-rule (edge (Listof (Pairof Symbol Any)) -> (Listof Rule-Spec))) -(define (parse-scope-rule E vars) - ;; E : [ScopeRule ::= (ScopeSignature ";")] - (: mk-type (LHS (Listof (Pairof Symbol Any)) -> SExpr)) - (define (mk-type lhs formals) '()) - (: mk-code (LHS (Listof (Pairof Symbol Any)) -> Sexp)) - (define (mk-code lhs formals) '()) - (let ([sig (first (edge-found E))]) - (map (λ: ([rs : Rule-Spec]) - ;; TODO: make this cleaner somehow - (let ([lhs (car rs)] - [terms (map (λ: ([t : (U (Listof Term) half-rule)]) - (match t - [(half-rule rhs assoc prec vars code) - (half-rule rhs assoc prec vars #f)] - [_ t])) - (cddr rs))]) - (cons lhs (cons '::= terms)))) - (parse-scope-signature sig mk-type mk-code vars)))) - -(: parse-expression/binding (edge -> (Values (Listof Term) Assoc Prec))) -(define (parse-expression/binding E) - ;; E : [Expression/Binding ::= Term/Binding+ (Term/Binding+ Attr)] - (let ([ts (parse-term/binding+ (first (edge-found E)))]) - (cond [(list1? (edge-found E)) - (values ts '⊥ '⊥)] - [(list2? (edge-found E)) - (let ([attr (second (edge-found E))]) - (let-values ([(assoc prec) (parse-attr attr)]) - (values ts assoc prec)))] - [else (error "parse-expression/binding unexpected:" E)]))) - -(: parse-term/binding (edge -> Term)) -(define (parse-term/binding E) - ;; E : [Term/Binding ::= Term Binding] - (let ([t (first (edge-found E))]) - (if (eq? 'Binding (edge-lhs t)) - (parse-binding t) - (parse-term t)))) - -(: parse-binding (edge -> Term)) -(define (parse-binding E) - ;; E : [Binding ::= *Name ":" Type] - (cons (unparse (first (edge-found E))) - (parse-type (third (edge-found E))))) - -(: parse-rule+ (edge -> (Listof Rule-Spec))) -(define (parse-rule+ E) - ;; E : [Rule+ ::= (Rule (? Rule+))] - (apply append (parse-rec E (mk-base parse-rule) first (mk-rec second)))) - -(: parse-term+ (edge -> (Listof Term))) -(define (parse-term+ E) - ;; E : [Term+ ::= (Term (? Term+))] - (parse-rec E (mk-base parse-term) first (mk-rec second))) - -(: parse-term/binding+ (edge -> (Listof Term))) -(define (parse-term/binding+ E) - ;; E : [Term/Binding+ ::= (Term/Binding (? Term/Binding+))] - (parse-rec E (mk-base parse-term/binding) first (mk-rec second))) - -(: parse-binding+ (edge -> (Listof Term))) -(define (parse-binding+ E) - ;; E : [Binding+ ::= (Binding (? Binding+))] - (parse-rec E (mk-base parse-binding) first (mk-rec second))) - -(: parse-binding-list (edge -> (Listof Term))) -(define (parse-binding-list E) - ;; E : [BindingList ::= (Binding (Binding "," BindingList))] - (parse-rec E (mk-base parse-binding) first (mk-rec third))) - -(: parse-sexp+ (edge -> Sexp)) -(define (parse-sexp+ E) - ;; E : [SExp+ ::= (SExp (? SExp+))] (i.e., SExp ~ Text) - (let ([ts (vector->list (extract-text E))]) - (with-input-from-string - (string-join (map token-value ts) " ") - read))) - -(define-syntax-rule (mk-base base) - (λ: ([e : Edge-Term]) - (base e))) - -(define-syntax-rule (mk-rec rec) - (λ: ([es : (Listof Edge-Term)]) - (rec es))) - -(: parse-rec - (All (T) (edge (Edge-Term -> T) ((Listof Edge-Term) -> Edge-Term) - ((Listof Edge-Term) -> edge) -> (Listof T)))) -(define (parse-rec E base fst rec) - ;; for parsing recursive grammar rules, e.g., A ::= B | B A; - ;; (define (parse-A E) - ;; (parse-rec E parse-B first second)) - (let loop ([E E] [F '()]) - (let ([e (base (fst (edge-found E)))]) - (if (list1? (edge-found E)) - (reverse (cons e F)) - (loop (rec (edge-found E)) (cons e F)))))) - -(: get-formals ((Listof Term) -> (Listof (Pairof Symbol Any)))) -(define (get-formals t/bs) - (let loop ([bs t/bs] [formals '()]) - (match bs - ['() (reverse formals)] - [(list (cons (? string? s) v) _ ...) - (let ([f (cons (string->symbol s) v)]) - (loop (cdr bs) (cons f formals)))] - [_ (loop (cdr bs) formals)]))) - -(: fun-parse? ((HashTable Symbol (Option (Listof Symbol))) -> - (edge -> Boolean))) -(define (fun-parse? args) - (λ: ([e : edge]) - (and (edge-complete? e) - (hash-has-key? args (cdr (edge-src e)))))) - -(: extract-text (edge -> (Vectorof token))) -(define (extract-text E) - ;; E : [Text+ ::= (Text (? Text+))] - (let ([parse-text - (λ: ([p : Edge-Term]) - (match p - [(cons (or 'Text 'SExp) (? token? t)) t]))]) - (let loop ([E E] [txt '()]) - (let ([t (parse-text (first (edge-found E)))]) - (if (list1? (edge-found E)) - (list->vector (reverse (cons t txt))) - (loop (second (edge-found E)) - (cons t txt))))))) - -(: scope-extension? (edge -> Boolean)) -(define (scope-extension? E) - (and (eq? 'Extension (edge-lhs E)) - (eq? 'Scope (edge-lhs (first (edge-found E)))))) - -(: env-lookup - (case-> [Env String -> Any] - [Env String (-> Any) -> Any])) -(define env-lookup - (let ([lk (λ: ([env : Env] [x : String] [failure-result : (-> Any)]) - (match env - [(cons (? hash? vars) next) - (hash-ref vars x (λ () (env-lookup next x failure-result)))] - [_ (failure-result)]))]) - (case-lambda: - [([env : Env] [x : String]) - (lk env x (λ () (error "unbound variable:" x)))] - [([env : Env] [x : String] [failure-result : (-> Any)]) - (lk env x failure-result)]))) - -(: make-env (Env (Listof (HashTable LHS Any)) -> Env)) -(define (make-env top-env vs) - (: vars->env ((HashTable LHS Any) -> (HashTable String Any))) - (define (vars->env vars) - (let ([new-env (make-hash)]) - (hash-for-each vars - (λ: ([k : LHS] [v : Any]) - (when (and (string? k) (list? v)) - (for-each - (λ (p) - (when (pair? p) - (let ([s (car p)] [lhs (cdr p)]) - (when (and (string? s) (rule-lhs? lhs) - (not (string? lhs))) - (let ([val (or (lookup vars lhs) lhs)]) - (hash-set! new-env s val)))))) v)))) - new-env)) - (let ([new-env (make-hash)]) - (for ([env (map vars->env vs)]) - (hash-for-each env - (λ: ([k : String] [v : Any]) - (if (hash-has-key? new-env k) - (let ([new-v (hash-ref new-env k)]) - (unless (member v new-v) - (hash-set! new-env k (cons v new-v)))) - (hash-set! new-env k (list v)))))) - (cons new-env top-env))) - -(: next-state/declare - ((Option parser-state) edge grammar grammar Env Boolean -> - (Option parser-state))) -(define (next-state/declare state body G H env aux?) - (: mk-update? (Integer (Setof LHS) -> (edge -> Boolean))) - (define (mk-update? j types) - (λ: ([e : edge]) - (and (= (edge-start e) j) - (= (edge-end e) j) - (edge-incomplete? e) - (set-member? types (edge-lhs e))))) - (: add! (edge Chart -> Void)) - (define (add! e chart) - (for ([c (list (car chart) (cdr chart))]) - (let* ([j (edge-start e)] - [lst (vector-ref c j)]) - (unless (member e lst) - (vector-set! c j (cons e lst)))))) - (match state - [(parser-state c1 c1-dep param-spec counts stats es aux) - (let* ([j (- (vector-length (cdr c1)) 1)] - [ts (list->set (map rule-lhs (grammar-lexicon H)))] - [es (chart-filter (mk-update? j ts) c1 j 'start)] - [ls (list->set (map edge-lhs es))]) - (for: ([lhs : LHS (set->list ls)]) - (for: ([r : rule (rewrites-for lhs H)]) - (let ([A (rule-lhs r)] - [x (rule-rhs r)] - [src (rule-src r)] - [vars (make-hash)]) - (add! (edge j j A '() '() x '⊥ '⊥ vars #f src) c1)))) - (next-state state body G env aux?))] - [_ #f])) - -(: state/undeclare! (parser-state grammar -> Void)) -(define (state/undeclare! state G) - (: mk-update? (Integer (Setof LHS) -> (edge -> Boolean))) - (define (mk-update? j types) - (λ: ([e : edge]) - (and (= (edge-start e) j) - (= (edge-end e) j) - (edge-incomplete? e) - (set-member? types (edge-lhs e))))) - (: remove! (edge Chart -> Void)) - (define (remove! e chart) - (for ([c (list (car chart) (cdr chart))]) - (let* ([j (edge-start e)] - [lst (vector-ref c j)]) - (vector-set! c j (remove e lst))))) - (match state - [(parser-state c1 c1-dep param-spec counts stats es aux) - (let* ([j (- (vector-length (cdr c1)) 1)] - [ts (list->set (map rule-lhs (grammar-lexicon G)))] - [es (chart-filter (mk-update? j ts) c1 j 'start)] - [ls (list->set (map edge-lhs es))]) - (for: ([lhs : LHS (set->list ls)]) - (for: ([r : rule (rewrites-for lhs G)]) - (let ([A (rule-lhs r)] - [x (rule-rhs r)] - [src (rule-src r)] - [vars (make-hash)]) - (remove! (edge j j A '() '() x '⊥ '⊥ vars #f src) c1)))))])) - -(: next-state - ((Option parser-state) edge grammar Env Boolean -> (Option parser-state))) -(define (next-state state body G env aux?) - (and state - (let ([words (extract-text (first (edge-found body)))]) - (next-state-tokens state words G env aux?)))) - -(: next-state-tokens - ((Option parser-state) (Vectorof token) grammar Env Boolean -> - (Option parser-state))) -(define (next-state-tokens state tokens G env aux?) - (match state - [(parser-state c1 c1-dep param-spec counts stats es aux) - (let* ([end (- (vector-length (cdr c1)) 1)] - [c2 (resume-chart tokens G c1)] - [aa (resume-agenda tokens G end env aux?)] - [agenda (car aa)] - [aux (cdr aa)]) - (parser-state c2 c1-dep param-spec counts stats agenda aux))] - [_ #f])) - -(: close-state (parser-state grammar -> (Listof Sexp))) -(define (close-state state G) - (match state - [(parser-state c1 c1-dep param-spec counts stats es aux) - (map (λ: ([e : edge]) (edge->ast e *edge->ast-terminals?*)) - (chart->parses c1 (grammar-start G)))])) - -(: resume-agenda - ((Vectorof token) grammar Integer Env Boolean -> - (Pairof (Listof edge) (Listof (Listof edge))))) -(define (resume-agenda tokens G start env aux?) - (let loop ([agenda '()] - [aux '()] - [i 0]) - (if (= i (vector-length tokens)) - (cons (reverse agenda) - (list (if aux? (reverse aux) '()))) - (let* ([t (vector-ref tokens i)] [w (token-value t)] - [rn (cons (grammar-id G) (string->symbol w))] - [j (+ i start)] [k (+ j 1)] [lhs w] [rhs (list t)] - [use-aux? #f] - [es (sort - (map - (λ (new-lhs) - (set! use-aux? #t) - (let ([lhs new-lhs] - [rhs (list (cons w t))] - [lr '()] - [vars (make-hash)]) - (edge j k lhs lr rhs lr '⊥ '⊥ vars #f rn))) - (env-lookup env w null)) - (λ: ([e : edge] [f : edge]) - (more-specific? (edge-lhs e) (edge-lhs f) G)))] - [f (edge j k w '() (list t) '() '⊥ '⊥ (make-hash) #f rn)]) - (if use-aux? - (let ([as (append aux (cons f (cdr es)))]) - (loop (cons (car es) agenda) as (+ i 1))) - (loop (cons f agenda) aux (+ i 1))))))) - -(: resume-chart ((Vectorof token) grammar Chart -> Chart)) -(define (resume-chart tokens G chart) - (let ([c (bu-initial-chart (vector-drop-right tokens 1) G)]) - (cons (vector-append (car chart) (car c)) - (vector-append (cdr chart) (cdr c))))) - -(: test (String -> Void)) -(define (test filename) - (printf "island: ") - (printf " trees=~a~n" (length (parse-file/island filename #f #t))) - (printf "bu-earley:") - (printf " trees=~a~n" (length (parse-file/bu-earley filename #f #t))) - (printf "td-earley:") - (printf " trees=~a~n" (length (parse-file/td-earley filename #f #t))) - (void)) diff --git a/src/grammar.rkt b/src/grammar.rkt deleted file mode 100644 index 244238c..0000000 --- a/src/grammar.rkt +++ /dev/null @@ -1,280 +0,0 @@ -;;;;;; grammar.rkt - Grammar module. -*- Mode: Racket -*- -;;;;;; Author: Erik Silkensen -;;;;;; Version: 3 Sep 2012 - -#lang typed/racket/no-check - -(require "utils.rkt") - -(provide (all-defined-out)) - -(define (rule-lhs? x) - (or (string? x) - (sexpr? x))) - -(define (sexpr? x) - (or (symbol? x) - (and (list? x) - (andmap sexpr? x)))) - -(define (sexp? x) - (or (symbol? x) - (string? x) - (char? x) - (boolean? x) - (number? x) - (and (or (vector? x) - (list? x)) - (for/and ([e x]) - (sexp? e))) - (and (pair? x) - (sexp? (car x)) - (sexp? (cdr x))))) - -(define (sexp-list? x) - (and (list? x) - (andmap sexp? x))) - -(define (symbol-list? x) - (and (list? x) - (andmap symbol? x))) - -(define (assoc? x) - (or (eq? '⊥ x) - (eq? 'left x) - (eq? 'right x) - (eq? 'non x))) - -(define (prec? x) - (or (eq? '⊥ x) (zero? x) (exact-positive-integer? x))) - -(struct grammar (start rules name id) #:transparent) - -(struct rule (lhs rhs assoc prec vars code src) #:transparent) - -(struct half-rule (rhs assoc prec vars code) #:transparent) - -(define-type Rule-Spec - (Pairof LHS (Pairof '::= (Listof (U (Listof Term) half-rule))))) - -(define-syntax-rule (define-grammar name rule ...) - (define name (mk-grammar `(rule ...) 'name))) - -(: mk-grammar ((Listof Rule-Spec) Symbol -> grammar)) -(define (mk-grammar rules name) - (define id (interned-gensym 'GID)) - (define (gensym-rule) (cons id (interned-gensym name))) - - (: expand-rule ((Listof Term) -> (Listof (Listof Term)))) - (define (expand-rule ts) - (if (null? ts) - (list ts) - (let ([rst (expand-rule (cdr ts))]) - (match (car ts) - [(list '? t1) - (append rst (map (λ (rs) - (cons t1 rs)) - rst))] - [t1 (map (λ (rs) - (cons t1 rs)) - rst)])))) - - (: format-rule (Rule-Spec -> (Listof rule))) - (define (format-rule t) - (let loop ([rls (cddr t)] [rs '()]) - (if (null? rls) - (reverse rs) - (if (half-rule? (car rls)) - (match (car rls) - [(half-rule rhs assoc prec vars code) - (let* ([src (gensym-rule)] - [r (rule (car t) rhs assoc prec vars code src)]) - (loop (cdr rls) (cons r rs)))]) - (let ([rst (map (λ (rhs) - (let ([lhs (car t)] - [src (gensym-rule)]) - (rule lhs rhs '⊥ '⊥ (make-hash) #f src))) - (expand-rule (car rls)))]) - (loop (cdr rls) (append rst rs))))))) - - (let* ([rrs (map format-rule rules)] - [rh (make-hash)]) - (for ([rs rrs]) - (for ([r rs]) - (hash-update! - rh (rule-lhs r) (λ (ss) (cons r ss)) null))) - (let ([S (if (null? rrs) 'grammar (rule-lhs (caar rrs)))]) - (grammar S rh name id)))) - -(: add-lexicon (String grammar -> grammar)) -(define (add-lexicon word g) - (if (category? word word g) - g - (let* ([src (cons (grammar-id g) (string->symbol word))] - [r (rule word (list word) '⊥ '⊥ (make-hash) #f src)] - [update (λ (rs) (cons r rs))]) - (grammar - (grammar-start g) - (hash-update (grammar-rules g) word update null) - (grammar-name g) - (grammar-id g))))) - -(: grammar-union (grammar grammar -> grammar)) -(define (grammar-union g h) - (let ([rules (make-hash)]) - (hash-for-each - (grammar-rules g) - (λ (lhs rs) - (hash-set! rules lhs rs))) - (hash-for-each - (grammar-rules h) - (λ (lhs rs) - (let ([update (λ (grs) (append grs rs))]) - (hash-update! rules lhs update null)))) - (let ([S (grammar-start (if (eq? 'grammar (grammar-start g)) h g))]) - (grammar S rules 'U (interned-gensym 'U))))) - -(: rewrites-for (LHS grammar -> (Listof rule))) -(define (rewrites-for x g) - - (: subst (Term rule -> rule)) - (define (subst x r) - (match r - [(rule lhs rhs assoc prec vars code src) - (let loop ([rhs rhs] [new-rhs '()]) - (if (null? rhs) - (let ([vars (hash-copy vars)]) - (hash-set! vars lhs x) - (rule lhs (reverse new-rhs) assoc prec vars code src)) - (let ([t (car rhs)]) - (cond [(equal? t lhs) - (loop (cdr rhs) (cons x new-rhs))] - [(and (pair? t) (string? (car t)) (equal? (cdr t) lhs)) - (let ([p (cons (car t) x)]) - (loop (cdr rhs) (cons p new-rhs)))] - [else (loop (cdr rhs) (cons (car rhs) new-rhs))]))))])) - - (: lookup (LHS (HashTable LHS (Listof rule)) -> (Listof rule))) - (define (lookup x rules) - (let loop ([rvs (expand-rules rules)] [rs '()]) - (if (null? rvs) - (reverse rs) - (let ([r (car rvs)]) - (cond [(equal? (rule-lhs r) x) - (loop (cdr rvs) (cons r rs))] - [(parameterized-rule? r) - (loop (cdr rvs) (cons (subst x r) rs))] - [else (loop (cdr rvs) rs)]))))) - - (if (string? x) - (let ([src (cons (grammar-id g) 'str)]) - (list (rule x (list x) '⊥ '⊥ (make-hash) #f src))) - (let ([rs (lookup x (grammar-rules g))]) - (if (not (null? rs)) - rs - (if (rule-rec? x) - (let ([rhs (list (rule-base x) x)] - [src (cons (grammar-id g) 'rec)]) - (list (rule x rhs '⊥ '⊥ (make-hash) #f src))) - '()))))) - -(: category (String grammar -> (Listof LHS))) -(define (category word g) - (filter (λ (cat) - (category? word cat g)) - (hash-keys (grammar-rules g)))) - -(: category? (String LHS grammar -> Boolean)) -(define (category? word category g) - (ormap (λ (r) - (and (list1? (rule-rhs r)) - (rule-match? (car (rule-rhs r)) word))) - (hash-ref (grammar-rules g) word null))) - -(: rule-match? (Term Term -> Boolean)) -(define (rule-match? x y) - (or (and (regexp? x) (string? y) - (not (not (regexp-match x y)))) - (and (procedure? x) (string? y) - (not (not (x y)))) - (equal? x y))) - -(: get-lexical-term ((U rule Rule-Spec) -> (Option Term))) -(define (get-lexical-term r) - (if (rule? r) - (match (rule-rhs r) - [(list t) t] - [_ #f]) - (match (cddr r) - [(list (half-rule (list t) _ _ _ _)) t] - [(list (list t)) t] - [_ #f]))) - -(: lexical-rule? ((U rule Rule-Spec) -> Boolean)) -(define (lexical-rule? r) - (let ([t (get-lexical-term r)]) - (or (string? t) - (regexp? t) - (procedure? t)))) - -(: grammar-lexicon (grammar -> (Listof rule))) -(define (grammar-lexicon g) - (filter lexical-rule? (all-rules g))) - -(: rule-rec? (LHS -> Boolean)) -(define (rule-rec? category) - (and (symbol? category) - (let ([lhs (symbol->string category)]) - (char=? #\+ (string-ref lhs (- (string-length lhs) 1)))))) - -(: rule-base (LHS -> LHS)) -(define (rule-base category) - (if (symbol? category) - (let ([lhs (symbol->string category)]) - (string->symbol (substring lhs 0 (- (string-length lhs) 1)))) - category)) - -(: parameterized-rule? (rule -> Boolean)) -(define (parameterized-rule? rule) - (hash-has-key? (rule-vars rule) (rule-lhs rule))) - -(: more-specific? (LHS LHS grammar -> Boolean)) -(define (more-specific? A B g) - ;; return B =>* A in g - (let loop ([rules (rewrites-for B g)]) - (and (not (null? rules)) - (let ([rhs (rule-rhs (car rules))]) - (or (and (list1? rhs) - (let ([t (car rhs)]) - (or (equal? A t) - (and (pair? t) - (equal? A (cdr t))) - (and (rule-lhs? t) (not (string? t)) - (more-specific? A t g))))) - (loop (cdr rules))))))) - -(: is-derivation? (String grammar -> Boolean)) -(define (is-derivation? a g) - ;; return A => a for some A in g - (ormap (λ (r) - (and (list1? (rule-rhs r)) - (rule-match? (car (rule-rhs r)) a))) - (expand-rules (grammar-rules g)))) - -(: fun-def? (rule -> Boolean)) -(define (fun-def? rule) - (not (not (rule-code rule)))) - -(: expand-rules ((HashTable LHS (Listof rule)) -> (Listof rule))) -(define (expand-rules rules) - (let loop ([rs (hash-values rules)] - [ret '()]) - (if (null? rs) - ret - (loop (cdr rs) (append ret (car rs)))))) - -(: all-rules (grammar -> (Listof rule))) -(define (all-rules g) - (apply append (hash-values (grammar-rules g)))) - -(define null (λ () '())) diff --git a/src/lexer.rkt b/src/lexer.rkt deleted file mode 100644 index 1ef76df..0000000 --- a/src/lexer.rkt +++ /dev/null @@ -1,880 +0,0 @@ -;;;;;; lexer.rkt - Lexical Analyzer module. -*- Mode: Racket -*- -;;;;;; Author: Erik Silkensen -;;;;;; Version: 3 Sep 2012 - -#lang typed/racket/no-check - -(require "utils.rkt") - -(provide - read-token - peek-token - match-token - tokenize-file - tokenize-string - tokenize-input - token - token? - token-name - token-value - token-position - token-column - token-line - token-source - token->list) - -(define-type Location (Pairof (Option Integer) (Option Integer))) - -(struct: token - ([name : Symbol] [value : String] [position : Location] [source : String]) - #:transparent) - -(: tokenize-file : (String -> (Vectorof token))) -(define (tokenize-file filename) - (with-input-from-file filename - (λ () (tokenize-input (current-input-port) filename)))) - -(: tokenize-string : (String String -> (Vectorof token))) -(define (tokenize-string string src) - (with-input-from-string string - (λ () (tokenize-input (current-input-port) src)))) - -(: tokenize-input (Input-Port String -> (Vectorof token))) -(define (tokenize-input in src) - (port-count-lines! in) - (let: loop : (Vectorof token) ([ts : (Listof token) '()]) - (let ([tok (read-token in src)]) - (if tok - (let ([val (if (string-token? tok) - (format "~a" (token-value tok)) - (token-value tok))]) - (loop (cons (token (token-name tok) val - (token-position tok) (token-source tok)) - ts))) - (list->vector (reverse ts)))))) - -(: *peek* (Listof (Option token))) -(define *peek* '()) - -(: read-token (Input-Port String -> (Option token))) -(define (read-token in src) - (if (null? *peek*) - ( in src) - (pop! *peek*))) - -(: peek-token (Input-Port String -> (Option token))) -(define (peek-token in src) - (if (null? *peek*) - (let ([token (read-token in src)]) - (set! *peek* (if token (list token) '())) - token) - (pop! *peek*))) - -(: match-token - (case-> [Regexp -> (String -> (Option String))] - [Regexp (Listof String) -> (String -> (Option String))])) -(define match-token - (let ([mt (λ: ([regexp : Regexp] [except : (Listof String)]) - (λ: ([str : String]) - (and (regexp-match regexp str) - (not (member str except)) - str)))]) - (case-lambda: - [([regexp : Regexp]) - (mt regexp '())] - [([regexp : Regexp] [except : (Listof String)]) - (mt regexp except)]))) - -(: (Input-Port String -> (Option token))) -(define ( in src) - ;; the starting state for every token. #f is returned at the end of - ;; input, a token object is returned if possible, and an error is - ;; raised otherwise - (let* ([next-loc (next-location in)] [next-char (peek-char in)]) - (cond [(eof-object? next-char) #f] - [(char-whitespace? next-char) - (begin (read-char in) - ( in src))] - [(char=? #\/ next-char) - ( (list (read-char/no-eof in)) next-loc in src)] - [(char-identifier-initial? next-char) - ( (list (read-char/no-eof in)) next-loc in src)] - [(char=? #\# next-char) - ( (list (read-char/no-eof in)) next-loc in src)] - [(or (char-peculiar? next-char) - (char-numeric? next-char)) - ( '() next-loc in src)] - [(char=? #\" next-char) - ( (list (read-char/no-eof in)) next-loc in src)] - [(char=? #\, next-char) - ( (list (read-char/no-eof in)) next-loc in src)] - [(char=? #\. next-char) - ( (list (read-char/no-eof in)) next-loc in src)] - [(char=? #\: next-char) - ( (list (read-char/no-eof in)) next-loc in src)] - [(char=? #\\ next-char) - ( (list (read-char/no-eof in)) next-loc in src)] - [else - (let ([next-char (read-char/no-eof in)]) - (cond [(char=? #\( next-char) - (token 'LEFT-PAREN "(" next-loc src)] - [(char=? #\) next-char) - (token 'RIGHT-PAREN ")" next-loc src)] - [(char=? #\' next-char) - (token 'SINGLE-QUOTE "'" next-loc src)] - [(char=? #\` next-char) - (token 'BACKQUOTE "`" next-loc src)] - [(char=? #\[ next-char) - (token 'LEFT-BRACKET "[" next-loc src)] - [(char=? #\] next-char) - (token 'RIGHT-BRACKET "]" next-loc src)] - [(char=? #\{ next-char) - (token 'LEFT-BRACE "{" next-loc src)] - [(char=? #\} next-char) - (token 'RIGHT-BRACE "}" next-loc src)] - [(char=? #\; next-char) - (token 'SEMICOLON ";" next-loc src)] - [(char=? #\| next-char) - (token 'BAR "|" next-loc src)] - [else - (syntax-error next-loc next-char)]))]))) - -(: ((Listof Char) Location Input-Port String -> (Option token))) -(define ( chars location in src) - ;; a line comment begins with ``//'' and extends until the end of the - ;; line. this procedure assumes that the first ``/'' has already been - ;; matched - (let ([next-char (peek-char/no-eof in)]) - (cond [(char=? #\/ next-char) - (read-line in) - ( in src)] - [else ( chars location in src)]))) - -(: ((Listof Char) Location Input-Port String -> (Option token))) -(define ( chars location in src) - ;; an identifier begins with an identifier-initial and extends (with - ;; identifier-subsequent) until a delimiter. it is an error for an - ;; identifier not to be terminated by a delimiter (or the end of input). - ;; this procedure assumes that an identifier-initial has already been - ;; matched - (let ([next-char (peek-char/no-eof in)]) - (cond [(char=? #\: next-char) - (let* ([this-char (read-char/no-eof in)] - [next-char (peek-char/no-eof in)]) - (if (and (char-delimiter? next-char) - (not (char=? #\: next-char)) - (not (char=? #\( next-char))) - (let* ([chars (cons this-char chars)] - [value (list->string (reverse chars))]) - (push! ( in src) *peek*) - (token 'IDENTIFIER value location src)) - (let* ([value (list->string (reverse chars))] - [chars (cons this-char chars)]) - (push! ( chars location in src) *peek*) - (token 'IDENTIFIER value location src))))] - [(char-identifier-subsequent? next-char) - ( (cons (read-char/no-eof in) chars) location in src)] - [(or (char-delimiter? next-char) - (char=? #\. next-char)) - (let ([value (list->string (reverse chars))]) - (token 'IDENTIFIER value location src))] - [else - (syntax-error location (list->string (reverse chars)))]))) - -(: ((Listof Char) Location Input-Port String -> (Option token))) -(define ( chars location in src) - ;; a sharp ``#'' is the starting state for several tokens. this - ;; procedure assumes that the sharp has already been matched, and then - ;; moves to the next state. - ;; ::= | | | | - ;; ff none of these alternatives match, an is assumed - (let ([next-char (peek-char/no-eof in)]) - (cond [(char=? #\( next-char) - ( (cons (read-char/no-eof in) chars) location in src)] - [(char-boolean? next-char) - ( (cons (read-char/no-eof in) chars) location in src)] - [(char=? #\\ next-char) - ( (cons (read-char/no-eof in) chars) location in src)] - [(or (char=? #\r next-char) - (char=? #\p next-char)) - ( chars location in src)] - [(or (char-radix? next-char) - (char-exactness? next-char)) - ( chars location in src)] - [else ( chars location in src)]))) - -(: ((Listof Char) Location Input-Port String -> (Option token))) -(define ( chars location in src) - ;; a vector ``#('' represents the start of a literal vector - ;; definition. this procedure assumes that the vector token has - ;; already been matched - (token 'VECTOR "#(" location src)) - -(: ((Listof Char) Location Input-Port String -> (Option token))) -(define ( chars location in src) - ;; a boolean ``#t'' or ``#f'' represents a literal boolean value. this - ;; procedure assumes that the boolean token has already been matched, - ;; and verifies that it terminates with a delimiter. it is an error - ;; for a boolean not to do so - (let ([next-char (peek-char in)]) - (if (char-delimiter? next-char) - (token 'BOOLEAN (list->string (reverse chars)) location src) - ( chars location in src)))) - -(: ((Listof Char) Location Input-Port String -> (Option token))) -(define ( chars location in src) - ;; a character has either the form ``#\'' or - ;; ``#\''. this procedure assumes that the ``#\'' has - ;; already been matched, and verifies that the rest of the token - ;; terminates with a delimiter. it is an error for a character not to - ;; do so. - (let ([next-char (peek-char/no-eof in)]) - (cond [(char=? #\s (char-downcase next-char)) - (let ([chars (cons (read-char/no-eof in) chars)] - [char-space (string->list "pace")]) - (if (char-delimiter? (peek-char in)) - (token 'CHARACTER (list->string (reverse chars)) location src) - ( chars char-space location in src)))] - [(char=? #\n (char-downcase next-char)) - (let ([chars (cons (read-char/no-eof in) chars)] - [char-newline (string->list "ewline")]) - (if (char-delimiter? (peek-char in)) - (token 'CHARACTER (list->string (reverse chars)) location src) - ( chars char-newline location in src)))] - [else - (let* ([chars (cons (read-char/no-eof in) chars)] - [value (list->string (reverse chars))] - [next-char (peek-char in)]) - (if (char-delimiter? next-char) - (token 'CHARACTER value location src) - (syntax-error location value)))]))) - -(: - ((Listof Char) (Listof Char) Location Input-Port String -> (Option token))) -(define ( chars match location in src) - ;; a character name is a special character constant (e.g. #\newline). - ;; this procedure assumes that the first character of the name has - ;; already been matched, matches until the match parameter is the null - ;; list, and then verifies that character name terminates with a - ;; delimiter. it is an error not to do so. - (let loop ([chars chars] [match match]) - (let ([next-char (peek-char in)]) - (cond [(and (char-delimiter? next-char) - (null? match)) - (token 'CHARACTER (list->string (reverse chars)) location src)] - [(and (not (null? match)) - (not (eof-object? (car match))) - (not (eof-object? next-char)) - (char=? (char-downcase next-char) (car match))) - (loop (cons (read-char/no-eof in) chars) (cdr match))] - [else (syntax-error location - (list->string (reverse chars)))])))) - -(: ((Listof Char) Location Input-Port String -> (Option token))) -(define ( chars location in src) - ;; a regex is the sequence #[rp]x. this procedure assumes that - ;; the opening ``#'' has already been matched - (let ([next-char (peek-char in)]) - (cond - [(eof-object? next-char) - (syntax-error location (list->string (reverse chars)))] - [(or (char=? #\r next-char) - (char=? #\p next-char)) - (let* ([regex-mode (read-char/no-eof in)] - [chars (cons regex-mode chars)] - [next-char (peek-char in)]) - (if (and (char? next-char) (char=? #\x next-char)) - (let* ([chars (cons (read-char/no-eof in) chars)] - [next-char (peek-char in)]) - (if (and (char? next-char) (char=? #\" next-char)) - (let* ([chars (begin (read-char in) (cddr chars))] - [tok ( chars location in src)] - [val (format "#~ax~a" regex-mode (token-value tok))]) - (token 'REGEX val (token-position tok) src)) - ( chars location in src))) - ( chars location in src)))] - [else - ( chars location in src)]))) - -(: ((Listof Char) Location Input-Port String -> token)) -(define ( chars location in src) - ;; a string is a sequence of characters (or escaped characters) - ;; terminating with a ``"''. this procedure assumes that the opening - ;; ``"'' has already been matched. tt is an error for a string not to - ;; terminate with a ``"''. - (let ([next-char (peek-char in)]) - (cond [(eof-object? next-char) - (syntax-error location (list->string (reverse chars)))] - [(char-string-element? next-char) - ( (cons (read-char/no-eof in) chars) location in src)] - [(char=? #\\ next-char) - (let* ([this-char (read-char in)] - [next-char (peek-char in)]) - (if (char-escape? next-char) - (let ([esc (char->escape (read-char/no-eof in))]) - ( (cons esc chars) location in src)) - (syntax-error location (list->string (reverse chars)))))] - [(char=? #\" next-char) - (let* ([next-char (read-char in)] - [value (list->string (cdr (reverse chars)))]) - (token 'STRING (format "\"~a\"" value) location src))] - [else - (syntax-error location (list->string (reverse chars)))]))) - -(: ((Listof Char) Location Input-Port String -> (Option token))) -(define ( chars location in src) - ;; a number token is made up of prefix and complex subtokens. in - ;; general, this procedure assumes that the start of a character has - ;; been detected, but not matched (i.e. consumed) - other than an - ;; initial ``#'' character - (let ([prefix (match-prefix chars in)]) - ( (car prefix) (cdr prefix) location in src))) - -(: match-prefix - ((Listof Char) Input-Port -> (Pairof (Listof Char) (Char -> Boolean)))) -(define (match-prefix chars in) - ;; attempts to match the prefix of a number. the return value is a - ;; pair where the first element is the list of characters so far - ;; matched, and the second element is a predicate function that - ;; returns whether or not a given character is a valid digit for a - ;; number with the detected radix. this procedure assumes that at most - ;; the initial ``#'' marking a radix or exactness has been matched - (let ([radix (match-radix chars in)]) - (if (not radix) - (if (char-exactness? (peek-char in)) - (let ([chars (cons (read-char/no-eof in) chars)]) - (or (match-#- match-radix chars in) - (cons chars char-numeric?))) - (cons chars char-numeric?)) - (let ([exactness (match-#- match-exactness (car radix) in)]) - (if exactness - (cons exactness (cdr radix)) - radix))))) - -(: match-radix - ((Listof Char) Input-Port -> - (Option (Pairof (Listof Char) (Char -> Boolean))))) -(define (match-radix chars in) - ;; attempts to match the radix of a number. the return value is a pair - ;; where the first element is the list of characters so far matched, - ;; and the second element is a predicate function that returns whether - ;; or not a given character is a valid digit for a number with the - ;; detected radix. if the radix is empty, it is assumed to be decimal. - ;; if the radix is invalid, #f is returned. this procedure assumes - ;; that the ``#'' (if present) has already been matched - (let ([next-char (peek-char in)]) - (if (and (char? next-char) (char-radix? next-char)) - (cons (cons (read-char/no-eof in) chars) - (char-radix->digits? next-char)) - #f))) - -(: match-exactness - ((Listof Char) Input-Port -> (Option (Listof Char)))) -(define (match-exactness chars in) - ;; attempts to match the exactness of a number. if an invalid - ;; exactness is detected, #f is returned. this procedure assumes that - ;; the ``#'' has already been matched - (let ([next-char (peek-char in)]) - (if (char-exactness? next-char) - (cons (read-char/no-eof in) chars) - #f))) - -(: - ((Listof Char) (Char -> Boolean) Location Input-Port String -> - (Option token))) -(define ( chars pred? location in src) - ;; the complex portion of a number is documented in Ch. 4.2.1 of the - ;; R^6RS sepcification. pred? should be a predicate procedure for - ;; testing whether or not a given character is valid for the number - ;; being matched. we follow many implementations in their choice to - ;; not follow the specification: a failed match of a number will - ;; usually transfer to the state - (let* ([sign (match-sign chars in)] - [next-char (peek-char in)]) - (if (and (char? next-char) (char=? #\i (char-downcase next-char))) - ( sign location in src) - (let* ([ureal (match-ureal-+ pred? sign in)] - [next-char (peek-char in)]) - (cond [(not ureal) - ( sign location in src)] - [(char-delimiter? next-char) - (token 'NUMBER (list->string (reverse ureal)) location src)] - [(and (char? next-char) (char=? #\@ next-char)) - (let ([chars (cons (read-char/no-eof in) ureal)]) - ( pred? chars location in src))] - [(char-sign? next-char) - (let* ([chars (cons (read-char/no-eof in) ureal)] - [digits (match-ureal-* pred? chars in)]) - (and digits ( digits location in src)))] - [else - ( ureal location in src)]))))) - -(: ((Listof Char) Location Input-Port String -> (Option token))) -(define ( chars location in src) - ;; matches the imaginary ``i'' portion of a number, where the ``i'' is - ;; meant to terminate the number. a move to the identifier state is - ;; possible - (let ([next-char (peek-char in)]) - (if (and (char? next-char) (char=? #\i (char-downcase next-char))) - (let* ([chars (cons (read-char/no-eof in) chars)] - [next-char (peek-char in)]) - (if (char-delimiter? next-char) - (token 'NUMBER (list->string (reverse chars)) location src) - ( chars location in src))) - ( chars location in src)))) - -(: - ((Char -> Boolean) (Listof Char) Location Input-Port String -> - (Option token))) -(define ( pred? chars location in src) - ;; matches a real number. pred? should be a predicate procedure for - ;; testing whether or not a given character is valid for the number - ;; being matched. this procedure assumes that at most the first digit - ;; has already been matched. it attempts to match a sign before - ;; transfering to the ureal state. - ( pred? (match-sign chars in) location in src)) - -(: - ((Char -> Boolean) (Listof Char) Location Input-Port String -> - (Option token))) -(define ( pred? chars location in src) - ;; matches an unsigned real number. pred? should be a predicate - ;; procedure for testing whether or not a given character is valid for - ;; the number being matched. this procedure assumes that at most the - ;; first digit has already been matched - (let* ([chars (match-uinteger-* pred? chars in)] - [next-char (peek-char in)]) - (cond [(char-delimiter? next-char) - (token 'NUMBER (list->string (reverse chars)) location src)] - [(and (char? next-char) (char=? #\/ next-char)) - (let ([chars (cons (read-char/no-eof in) chars)]) - ( pred? chars location in src))] - [(and (char? next-char) - (char=? #\. next-char) ; pred? must be char-numeric? - (eq? pred? char-numeric?)) ; in order to move to - ( (cons (read-char/no-eof in) chars) location in src)] - [(and (char? next-char) - (char-exponent-marker? next-char) - (eq? pred? char-numeric?)) - ( chars location in src)] - [else - (syntax-error location (list->string (reverse chars)))]))) - -(: match-ureal-+ - ((Char -> Boolean) (Listof Char) Input-Port -> (Option (Listof Char)))) -(define (match-ureal-+ pred? chars in) - ;; attempts to match an unsigned real number, requiring that at least - ;; one digit is matched immediately. pred? should be a predicate - ;; procedure for testing whether or not a given character is valid for - ;; the number being matched. #f is returned on error - (match-ureal match-uinteger-+ pred? chars in)) - -(: match-ureal-* - ((Char -> Boolean) (Listof Char) Input-Port -> (Option (Listof Char)))) -(define (match-ureal-* pred? chars in) - ;; attempts to match an unsigned real number. pred? should be a - ;; predicate procedure for testing whether or not a given character is - ;; valid for the number being matched. #f is returned on error - (match-ureal match-uinteger-* pred? chars in)) - -(: match-ureal - (((Char -> Boolean) (Listof Char) Input-Port -> (Option (Listof Char))) - (Char -> Boolean) (Listof Char) Input-Port -> (Option (Listof Char)))) -(define (match-ureal match pred? chars in) - ;; generic procedure that attempts to match an unsigned real number. - ;; match should be a procedure to apply immediately to the chars. - ;; pred? should be a procedure for testing whether or not a given - ;; character is valid for the number being matched. #f is returned on - ;; error - (let* ([chars (match pred? chars in)] - [next-char (peek-char in)]) - (cond [(not chars) #f] - [(char-delimiter? next-char) chars] - [(and (char? next-char) (char=? #\/ next-char)) - (match-uinteger-+ pred? (cons (read-char/no-eof in) chars) in)] - [(and (char? next-char) - (char=? #\. next-char) - (eq? pred? char-numeric?)) - (match-decimal (cons (read-char/no-eof in) chars) in)] - [(and (char? next-char) - (char-exponent-marker? next-char) - (eq? pred? char-numeric?)) - (match-suffix chars in)] - [else chars]))) - -(: - ((Char -> Boolean) (Listof Char) Location Input-Port String -> - (Option token))) -(define ( pred? chars location in src) - ;; matches an unsigned integer number. pred? should be a predicate - ;; procedure for testing whether or not a given character is valid for - ;; the number being mached. it is an error for a number to not be - ;; terminated with a delimiter - (let* ([digits (match-uinteger-+ pred? chars in)] - [next-char (peek-char in)]) - (if digits - (if (char-delimiter? next-char) - (token 'NUMBER (list->string (reverse digits)) location src) - (syntax-error location (list->string (reverse digits)))) - (syntax-error location (list->string (reverse chars)))))) - -(: match-uinteger-+ - ((Char -> Boolean) (Listof Char) Input-Port -> (Option (Listof Char)))) -(define (match-uinteger-+ pred? chars in) - ;; attempts to match an unsigned integer number, requiring that at - ;; least one digit is matched immediately. pred? should be a predicate - ;; procedure for testing whether or not a given character is valid for - ;; the number being matched. #f is returned on error - (let ([digits (match-+ pred? chars in)]) - (if digits digits #f))) - -(: match-uinteger-* - ((Char -> Boolean) (Listof Char) Input-Port -> (Listof Char))) -(define (match-uinteger-* pred? chars in) - ;; attempts to match an unsigned integer number. pred? should be a - ;; predicate procedure for testing whether or not a given character is - ;; valid for the number being matched - (let ([digits (match-* pred? chars in)]) - (if digits digits chars))) - -(: ((Listof Char) Location Input-Port String -> (Option token))) -(define ( chars location in src) - ;; a decimal number has an optional fractional component and ends with - ;; an optional exponent. this procedure assumes that at most the first - ;; character has been matched. ot is an error for a decimal number to - ;; not terminate with a delimiter - (let* ([digits (match-decimal chars in)] - [next-char (peek-char in)]) - (if (and digits - (char-delimiter? next-char)) - (token 'NUMBER (list->string (reverse digits)) location src) - (syntax-error location (list->string (reverse chars)))))) - -(: match-decimal ((Listof Char) Input-Port -> (Option (Listof Char)))) -(define (match-decimal chars in) - ;; attempts to match a decimal number. #f may be returned on error - (if (= (length chars) 1) - (let ([chars (match-uinteger-+ char-numeric? chars in)]) - (and chars (match-suffix chars in) )) - (match-suffix (match-uinteger-* char-numeric? chars in) in))) - -(: match-sign ((Listof Char) Input-Port -> (Listof Char))) -(define (match-sign chars in) - ;; attempts to match a sign (``+'' or ``-''). the characters matched - ;; are returned whether or not a sign is actually matched (i.e. no #f) - (let ([next-char (peek-char in)]) - (if (and (char? next-char) - (or (char=? #\+ next-char) - (char=? #\- next-char))) - (cons (read-char/no-eof in) chars) - chars))) - -(: ((Listof Char) Location Input-Port String -> (Option token))) -(define ( chars location in src) - ;; the suffix is the end of a decimal number. it may consist of an - ;; exponent. it is an error for a number to not be terminated with a - ;; delimiter. this procedure assumes that everything up until the - ;; start of the suffix has been matched - (let* ([digits (match-suffix chars in)] - [next-char (peek-char in)]) - (if (and digits (char-delimiter? next-char)) - (token 'NUMBER (list->string (reverse digits)) location src) - (syntax-error location (list->string (reverse chars)))))) - -(: match-suffix - ((Listof Char) Input-Port -> (Option (Listof Char)))) -(define (match-suffix chars in) - ;; attempts to match the suffix of a decimal number. because a suffix - ;; can be be empty, the original matched chars are returned if it is - ;; empty (i.e. no #f). this procedure assumes that everything up until - ;; the start of the suffix has been matched - (let ([next-char (peek-char in)]) - (cond [(char-delimiter? next-char) chars] - [(char-exponent-marker? next-char) - (set! chars (cons (read-char/no-eof in) chars)) - (set! chars (match-sign chars in)) - (match-+ char-numeric? chars in)] - [else chars]))) - -(: ((Listof Char) Location Input-Port String -> token)) -(define ( chars location in src) - ;; a comma may either be itself a token, or combine with the ``@'' - ;; symbol to make the COMMA-AT token. the comma token doesn't need to - ;; be explicitly terminated with a delimiter - (let ([next-char (peek-char in)]) - (if (and (char? next-char) (char=? #\@ next-char)) - (begin (read-char in) - (token 'COMMA-AT ",@" location src)) - (token 'COMMA "," location src)))) - -(: ((Listof Char) Location Input-Port String -> (Option token))) -(define ( chars location in src) - ;; a dot may itself be a token or it might be the start of a decimal - ;; number - (let ([next-char (peek-char in)]) - (cond [(and (= (length chars) 1) - (char? next-char) - (char-numeric? next-char)) - ( (cons (read-char/no-eof in) chars) location in src)] - [else (token 'DOT "." location src)]))) - -(: ((Listof Char) Location Input-Port String -> (Option token))) -(define ( chars location in src) - ;; a colon may itself be a token or it might be the start of a ::= - (let ([next-char (peek-char in)]) - (cond [(and (char? next-char) (char=? #\: next-char)) - (let* ([this-char (read-char/no-eof in)] - [next-char (peek-char in)]) - (if (and (char? next-char) (char=? #\= next-char)) - (begin (read-char in) - (token 'IDENTIFIER "::=" location src)) - ( (cons this-char chars) location in src)))] - [else (token 'COLON ":" location src)]))) - -(: ((Listof Char) Location Input-Port String -> token)) -(define ( chars location in src) - (let ([chars (reverse (cons (read-char/no-eof in) chars))]) - (token 'BACKSLASH (list->string chars) location src))) - -(: match-+ - ((Char -> Boolean) (Listof Char) Input-Port -> (Option (Listof Char)))) -(define (match-+ pred? chars in) - ;; a generic procedure that matches ``one or more'' characters - ;; satisfying the predicate procedure ``pred?''. if no characters - ;; match, #f is returned - (and (pred? (peek-char/no-eof in)) - (match-* pred? (cons (read-char/no-eof in) chars) in))) - -(: match-* ((Char -> Boolean) (Listof Char) Input-Port -> (Listof Char))) -(define (match-* pred? chars in) - ;; a generic procedure that matches ``zero or more'' characters - ;; satisfying the predicate procedure ``pred?''. if no characters - ;; match, chars is returned - (let loop ([chars chars]) - (if (pred? (peek-char/no-eof in)) - (loop (cons (read-char/no-eof in) chars)) - chars))) - -(: match-#- - (All (T) (((Listof Char) Input-Port -> T) (Listof Char) Input-Port -> - (Option T)))) -(define (match-#- chars in) - ;; a generic procedure that matches an opening ``#' and then calls the - ;; specified procedure with the characters so far matched and the - ;; input port. if the ``#'' match is unsuccessfull, #f is returned - (and (char=? #\# (peek-char/no-eof in)) - ( (cons (read-char/no-eof in) chars) in))) - -(: char-delimiter? ((U EOF Char) -> Boolean)) -(define (char-delimiter? char) - (or (eof-object? char) - (char-whitespace? char) - (char=? #\( char) - (char=? #\) char) - (char=? #\' char) - (char=? #\` char) - (char=? #\, char) - (char=? #\[ char) - (char=? #\] char) - (char=? #\{ char) - (char=? #\} char) - (char=? #\" char) - (char=? #\: char) - (char=? #\; char) - (char=? #\| char) - (char=? #\# char) - (char=? #\\ char))) - -(: char-identifier-initial? (Any -> Boolean)) -(define (char-identifier-initial? char) - (and (char? char) - (not (char-delimiter? char)) - (case char - [(#\! #\$ #\% #\& #\* #\/ #\< #\= #\> #\? #\^ #\_ #\~) #t] - [else (or (char-alphabetic? char) - (char-symbolic? char))]))) - -(: char-identifier-subsequent? (Any -> Boolean)) -(define (char-identifier-subsequent? char) - (and (char? char) - (or (char-identifier-initial? char) - (char-numeric? char) - (char=? #\+ char) - (char=? #\- char) - (char=? #\@ char)))) - -(: char-boolean? (Any -> Boolean)) -(define (char-boolean? char) - (and (char? char) - (let ([char (char-downcase char)]) - (or (char=? #\t char) - (char=? #\f char))))) - -(: char-string-element? (Any -> Boolean)) -(define (char-string-element? char) - (and (char? char) - (not (char=? #\" char)) - (not (char=? #\\ char)))) - -(: char-peculiar? (Any -> Boolean)) -(define (char-peculiar? char) - (char-sign? char)) - -(: char-escape? (Any -> Boolean)) -(define (char-escape? char) - (and (char? char) - (case (char-downcase char) - [(#\b #\t #\n #\v #\r #\" #\\) #t] - [else #f]))) - -(: char->escape (Char -> Char)) -(define (char->escape char) - (case (char-downcase char) - [(#\b) #\backspace] - [(#\t) #\tab] - [(#\n) #\newline] - [(#\r) #\return] - [(#\v) #\vtab] - [(#\" #\\) char] - [else (error "unexpected escape")])) - -(: char-exactness? (Any -> Boolean)) -(define (char-exactness? char) - (and (char? char) - (case (char-downcase char) - [(#\i #\e) #t] - [else #f]))) - -(: char-numeric-2? (Char -> Boolean)) -(define (char-numeric-2? char) - (or (char=? #\0 char) - (char=? #\1 char))) - -(: char-numeric-8? (Char -> Boolean)) -(define (char-numeric-8? char) - (let ([ord (char->integer char)]) - (and (>= ord #x30) - (<= ord #x37)))) - -(: char-numeric-16? (Char -> Boolean)) -(define (char-numeric-16? char) - (or (char-numeric? char) - (let ([ord (char->integer (char-downcase char))]) - (and (>= ord #x61) - (<= ord #x66))))) - -(: char-radix? (Char -> Boolean)) -(define (char-radix? char) - (case (char-downcase char) - [(#\b #\d #\o #\x) #t] - [else #f])) - -(: char-exponent-marker? ((U EOF Char) -> Boolean)) -(define (char-exponent-marker? char) - (and (char? char) - (case (char-downcase char) - [(#\e #\s #\f #\d #\l) #t] - [else #f]))) - -(: char-radix->digits? (Char -> (Char -> Boolean))) -(define (char-radix->digits? radix) - (case (char-downcase radix) - [(#\b) char-numeric-2?] - [(#\d) char-numeric?] - [(#\o) char-numeric-8?] - [(#\x) char-numeric-16?] - [else (λ (x) #f)])) - -(: radix->digits? (Char -> (Option (Char -> Boolean)))) -(define (radix->digits? radix) - (case radix - [(2) char-numeric-2?] - [(10) char-numeric?] - [(8) char-numeric-8?] - [(16) char-numeric-16?] - [else (λ (x) #f)])) - -(: char-sign? (Any -> Boolean)) -(define (char-sign? char) - (and (char? char) - (or (char=? #\+ char) - (char=? #\- char)))) - -(: identifier-token? (Any -> Boolean)) -(define (identifier-token? token) - (token-type? token 'IDENTIFIER)) - -(: boolean-token? (Any -> Boolean)) -(define (boolean-token? token) - (token-type? token 'BOOLEAN)) - -(: number-token? (Any -> Boolean)) -(define (number-token? token) - (token-type? token 'NUMBER)) - -(: character-token? (Any -> Boolean)) -(define (character-token? token) - (token-type? token 'CHARACTER)) - -(: string-token? (Any -> Boolean)) -(define (string-token? token) - (token-type? token 'STRING)) - -(: token-type? (Any Symbol -> Boolean)) -(define (token-type? token type) - (and (token? token) - (eq? (token-name token) type))) - -(: token->list (token -> (List Symbol String Location))) -(define (token->list token) - (list (token-name token) (token-value token) (token-position token))) - -(: token-line (token -> (Option Integer))) -(define (token-line token) - (and (pair? (token-position token)) - (car (token-position token)))) - -(: token-column (token -> (Option Integer))) -(define (token-column token) - (and (pair? (token-position token)) - (cdr (token-position token)))) - -(: next-location (Input-Port -> Location)) -(define (next-location in) - (let-values (((line-number line-column position) - (port-next-location in))) - (cons line-number line-column))) - -(: peek-char/no-eof (Input-Port -> Char)) -(define (peek-char/no-eof in) - (let ([c (peek-char in)]) - (if (eof-object? c) - (error "unexpected eof") - c))) - -(: read-char/no-eof (Input-Port -> Char)) -(define (read-char/no-eof in) - (let ([c (read-char in)]) - (if (eof-object? c) - (error "unexpected eof") - c))) - -(define-syntax syntax-error - (syntax-rules () - [(_ location near) - (error "bad syntax on line" - (car location) - 'near - near)])) - -(define-syntax push! - (syntax-rules () - [(_ x xs) - (set! xs (cons x xs))])) - -(define-syntax pop! - (syntax-rules () - [(_ xs) - (let ([x (car xs)]) - (set! xs (cdr xs)) - x)])) diff --git a/src/test-compile/Fun.es b/src/test-compile/Fun.es deleted file mode 100644 index 63fc56a..0000000 --- a/src/test-compile/Fun.es +++ /dev/null @@ -1,21 +0,0 @@ -module Fun { - types { - Type ::= T1:Type "->" T2:Type [right] == (T1 -> T2); - } - - forall T2. - T1 -> T2 ::= "fun" x:Id ":" T1:Type { x:T1; e1:T2 } => - (λ: ([x : T1]) e1); - - forall T1 T2. - T2 ::= f : T1 -> T2 x:T1 [left] => (f x); - - forall T1 T2. - T1 -> T2 ::= "fix" f : (T1 -> T2) -> (T1 -> T2) = - ((λ: ([x : (Rec A (A -> (T1 -> T2)))]) - (f (λ (y) ((x x) y)))) - (λ: ([x : (Rec A (A -> (T1 -> T2)))]) - (f (λ (y) ((x x) y))))); - - Id ::= #rx"^[a-zA-Z_][a-zA-Z0-9_]*$"; -} diff --git a/src/test-compile/ML.es b/src/test-compile/ML.es deleted file mode 100644 index 8c7a416..0000000 --- a/src/test-compile/ML.es +++ /dev/null @@ -1,28 +0,0 @@ -module ML { - types { - Type ::= "Int" == Integer; - Type ::= "Bool" == Boolean; - } - - Int ::= "|" x:Int "|" = (abs x); - Int ::= x:Int "+" y:Int [left 1] = (+ x y); - Int ::= x:Int "-" y:Int [left 1] = (- x y); - Int ::= x:Int "*" y:Int [left 2] = (* x y); - Bool ::= x:Int "<" y:Int = (< x y); - forall T. - Void ::= "print" x:T = (displayln x); - - forall T. - T ::= "if" test:Bool "then" e1:T "else" e2:T => - (if test e1 e2); - forall T1 T2. - T2 ::= "let" x:Id "=" e1:T1 { x:T1; e2:T2 } => - (let: ([x : T1 e1]) e2); - forall T1 T2. - T2 ::= e1:T1 ";" e2:T2 [left] => (begin e1 e2); - forall T. - T ::= "(" x:T ")" => x; - - Int ::= #rx"^[0-9]+$"; - Id ::= #rx"^[a-zA-Z_][a-zA-Z0-9_]*$"; -} diff --git a/src/test-compile/PairFun.es b/src/test-compile/PairFun.es deleted file mode 100644 index ffe7cb4..0000000 --- a/src/test-compile/PairFun.es +++ /dev/null @@ -1,37 +0,0 @@ -module PairFun { - types { - Type ::= T1:Type "×" T2:Type == (Pairof T1 T2); - Type ::= T1:Type "->" T2:Type [right] == (T1 -> T2); - } - - forall T1 T2. - T1 × T2 ::= "{" fst:T1 "," snd:T2 "}" - => (cons fst snd); - - forall T1 T2. - T1 ::= p : T1 × T2 "." "fst" - => (car p); - - forall T1 T2. - T2 ::= p : T1 × T2 "." "snd" - => (cdr p); - - forall T2. - T1 -> T2 ::= "fun" x:Id ":" T1:Type { x:T1; e1:T2 } - => (λ: ([x : T1]) e1); - - forall T1 T2. - T2 ::= f : T1 -> T2 x : T1 [left] - => (f x); - - forall T1 T2. - T1 -> T2 ::= "fix" f : (T1 -> T2) -> (T1 -> T2) - = ((λ: ([x : (Rec A (A -> (T1 -> T2)))]) - (f (λ (y) ((x x) y)))) - (λ: ([x : (Rec A (A -> (T1 -> T2)))]) - (f (λ (y) ((x x) y))))); - - Id ::= #px"^[:alpha:][:word:]*$"; -} - - diff --git a/src/test-compile/Sets.es b/src/test-compile/Sets.es deleted file mode 100644 index 0174ebf..0000000 --- a/src/test-compile/Sets.es +++ /dev/null @@ -1,26 +0,0 @@ -module Sets { - types { - Type ::= T:Type "Set" == (Setof T); - Type ::= T:Type "Seq" == (Listof T); - } - - forall T. - T Set ::= "{" x:T "}" => (set x); - forall T. - T Set ::= "{" x:T xs : (T Seq) "}" => (list->set (cons x xs)); - - forall T. - T Seq ::= "," x:T => (list x); - forall T. - T Seq ::= "," x:T xs : (T Seq) => (cons x xs); - - forall T. - T Set ::= s1 : (T Set) "|" s2 : (T Set) [left 1] = - (set-union s1 s2); - forall T. - T Set ::= s1 : (T Set) "&" s2 : (T Set) [left 2] = - (set-intersect s1 s2); - forall T. - Integer ::= "|" s : (T Set) "|" = - (set-count s); -} diff --git a/src/test-compile/Vector.es b/src/test-compile/Vector.es deleted file mode 100644 index 0ffab00..0000000 --- a/src/test-compile/Vector.es +++ /dev/null @@ -1,8 +0,0 @@ -module Vector { - types { - Type ::= "Vec" == (Vectorof Integer); - } - - Vec ::= x:Vec "+" y:Vec [left] = - (vector-map + x y); -} diff --git a/src/test-compile/abc.es b/src/test-compile/abc.es deleted file mode 100644 index 8eff7d5..0000000 --- a/src/test-compile/abc.es +++ /dev/null @@ -1,10 +0,0 @@ -import ML, Sets; - -let A = {1, 2, 3} { - let B = {2, 3, 4} { - let C = {3, 4, 5} { - print |A & C|; - print A | B & C - } - } -} diff --git a/src/test-compile/double.es b/src/test-compile/double.es deleted file mode 100644 index 0f9686d..0000000 --- a/src/test-compile/double.es +++ /dev/null @@ -1,10 +0,0 @@ -import ML, PairFun; - -let maybeDouble = - fun p : Bool × Int { - if p.fst then p.snd - else p.snd * 2 - } -{ - print maybeDouble {1 < 0, 21} -} diff --git a/src/test-compile/fact.es b/src/test-compile/fact.es deleted file mode 100644 index 195d9fb..0000000 --- a/src/test-compile/fact.es +++ /dev/null @@ -1,12 +0,0 @@ -import ML, Fun; - -let fact = - fix fun f : Int -> Int { - fun n : Int { - if n < 2 then 1 - else n * f (n - 1) - } - } -{ - print fact 5 -} diff --git a/src/test-compile/fun1.es b/src/test-compile/fun1.es deleted file mode 100644 index 27c297e..0000000 --- a/src/test-compile/fun1.es +++ /dev/null @@ -1,7 +0,0 @@ -import ML, Fun; - -let succ = fun x : Int { x + 1 } { - let n = succ 6 { - print 2 + n * 5 + 5 - } -} diff --git a/src/test-compile/fun2.es b/src/test-compile/fun2.es deleted file mode 100644 index 331ab0b..0000000 --- a/src/test-compile/fun2.es +++ /dev/null @@ -1,9 +0,0 @@ -import ML, Fun; - -let mk_add = fun x : Int { fun y : Int { x + y } } { - let succ = mk_add 1 { - let n = succ 6 { - print 2 + n * 5 + 5 - } - } -} diff --git a/src/test-compile/fun3.es b/src/test-compile/fun3.es deleted file mode 100644 index 7d81e54..0000000 --- a/src/test-compile/fun3.es +++ /dev/null @@ -1,9 +0,0 @@ -import ML, Fun; - -let mk_square = fun f : Int -> Int { fun x : Int { (f x) * (f x) } } { - let f = fun x : Int { x + 2 } { - let g = mk_square f { - print g 2 - } - } -} diff --git a/src/test-compile/fun4-ill.es b/src/test-compile/fun4-ill.es deleted file mode 100644 index b134b00..0000000 --- a/src/test-compile/fun4-ill.es +++ /dev/null @@ -1,12 +0,0 @@ -import ML, Fun; - -let fact = - fix fun f : Int -> Bool { - fun n : Int { - if n < 2 then 1 - else n * f (n - 1) - } - } -{ - print fact 5 -} diff --git a/src/test-compile/fun4.es b/src/test-compile/fun4.es deleted file mode 100644 index 195d9fb..0000000 --- a/src/test-compile/fun4.es +++ /dev/null @@ -1,12 +0,0 @@ -import ML, Fun; - -let fact = - fix fun f : Int -> Int { - fun n : Int { - if n < 2 then 1 - else n * f (n - 1) - } - } -{ - print fact 5 -} diff --git a/src/test-compile/let.es b/src/test-compile/let.es deleted file mode 100644 index bc6534c..0000000 --- a/src/test-compile/let.es +++ /dev/null @@ -1,6 +0,0 @@ -import ML; - -let n = 7 { - if n < 3 then print 6 - else print 2 + n * 5 + 5 -} diff --git a/src/test-compile/p1.es b/src/test-compile/p1.es deleted file mode 100644 index 0f9686d..0000000 --- a/src/test-compile/p1.es +++ /dev/null @@ -1,10 +0,0 @@ -import ML, PairFun; - -let maybeDouble = - fun p : Bool × Int { - if p.fst then p.snd - else p.snd * 2 - } -{ - print maybeDouble {1 < 0, 21} -} diff --git a/src/test-compile/vec.es b/src/test-compile/vec.es deleted file mode 100644 index 4527577..0000000 --- a/src/test-compile/vec.es +++ /dev/null @@ -1,8 +0,0 @@ -import Vector; - -declare u:Vec, v:Vec, w:Vec { - (let ([u #(1 2 3)] - [v #(4 5 6)] - [w #(7 8 9)]) - u + v + w) -} diff --git a/src/test-lexer.rkt b/src/test-lexer.rkt deleted file mode 100644 index 0f90736..0000000 --- a/src/test-lexer.rkt +++ /dev/null @@ -1,24 +0,0 @@ -;;;;;; test-lexer.rkt - Lexical Analyzer test module. -*- Mode: Racket -*- -;;;;;; Author: Erik Silkensen -;;;;;; Version: 16 Jan 2012 - -#lang racket - -(require "lexer.rkt") - -(printf ";; Lexical Analyzer test REPL~n") -(printf ";; Use Ctrl-D (i.e., EOF) to exit.~n") -(port-count-lines! (current-input-port)) -(let ([prompt "> "]) - (display prompt) - (flush-output) - (let repl ([tok (read-token (current-input-port) "#"))) - (newline)))) diff --git a/src/test-parse/Arith1.es b/src/test-parse/Arith1.es deleted file mode 100644 index f02085d..0000000 --- a/src/test-parse/Arith1.es +++ /dev/null @@ -1,8 +0,0 @@ -module Arith1 { - S ::= Exp | Exp S; - Exp ::= Add | Mul | Neg | Name; - Add ::= Exp "+" Exp [left 1]; - Mul ::= Exp "*" Exp [left 2]; - Neg ::= "-" Exp [3]; - Name ::= #rx"^[A-Z]$"; -} diff --git a/src/test-parse/Arith2.es b/src/test-parse/Arith2.es deleted file mode 100644 index 5249628..0000000 --- a/src/test-parse/Arith2.es +++ /dev/null @@ -1,8 +0,0 @@ -module Arith2 { - S ::= Exp | Exp S; - Exp ::= Add | Mul | Neg | Name; - Add ::= Exp "+" Exp [left 2]; - Mul ::= Exp "*" Exp [left 3]; - Neg ::= "-" Exp [1]; - Name ::= #rx"^[A-Z]$"; -} diff --git a/src/test-parse/BTO.es b/src/test-parse/BTO.es deleted file mode 100644 index ad67358..0000000 --- a/src/test-parse/BTO.es +++ /dev/null @@ -1,21 +0,0 @@ -module BTO { - input ::= VAR "in" param_list "out" param_list "{" prog "}"; - param ::= VAR ":" type; - param_list ::= param | param "," param_list; - orientation ::= "row" | "column"; - type ::= orientation "matrix" - | orientation "vector" - | "matrix" | "vector" | "scalar"; - prog ::= stmt | prog stmt; - stmt ::= VAR "=" expr; - expr ::= NUM - | VAR - | expr "+" expr [left 1] - | expr "-" expr [left 1] - | expr "*" expr [left 2] - | "-" expr [3] - | expr "'" [4] - | "(" expr ")"; - VAR ::= #rx"^[a-zA-Z][a-zA-Z0-9]*$"; - NUM ::= #rx"^[0-9]+(.[0-9]*)?$"; -} diff --git a/src/test-parse/Lambda.es b/src/test-parse/Lambda.es deleted file mode 100644 index 285d01d..0000000 --- a/src/test-parse/Lambda.es +++ /dev/null @@ -1,9 +0,0 @@ -module Lambda { - S ::= Stmt S | Stmt; - Stmt ::= Assign ";" | Term ";"; - Assign ::= Var "=" Term; - Term ::= Var | App | Abs | "(" Term ")"; - Var ::= #rx"[a-z]+"; - Abs ::= "lambda" Var "." Term; - App ::= Term Term [left]; -} diff --git a/src/test-parse/LetExp.es b/src/test-parse/LetExp.es deleted file mode 100644 index d9fcb55..0000000 --- a/src/test-parse/LetExp.es +++ /dev/null @@ -1,8 +0,0 @@ -module LetExp { - S ::= Exp | Exp S; - Exp ::= Let | Add | Id | Int; - Let ::= "let" Id "=" Exp "in" Exp [1]; - Add ::= Exp "+" Exp [left 2]; - Id ::= #rx"^[A-Za-z][A-Za-z0-9]*$"; - Int ::= #rx"^[0-9]+$"; -} diff --git a/src/test-parse/MA.es b/src/test-parse/MA.es deleted file mode 100644 index d184d24..0000000 --- a/src/test-parse/MA.es +++ /dev/null @@ -1,12 +0,0 @@ -module MA { - S ::= Stmt S | Stmt; - Stmt ::= Exp ";"; - Exp ::= Scalar | Vector | Matrix; - Scalar ::= "(" Scalar ")" - | Scalar "*" Scalar [left]; - Vector ::= "(" Vector ")" - | Vector "*" Scalar [left] | Scalar "*" Vector [left]; - Matrix ::= "(" Matrix ")" - | Matrix "*" Matrix [left] | Matrix "*" Scalar [left] - | Scalar "*" Matrix [left] | Matrix "*" Vector [left]; -} diff --git a/src/test-parse/Param.es b/src/test-parse/Param.es deleted file mode 100644 index aeb91fa..0000000 --- a/src/test-parse/Param.es +++ /dev/null @@ -1,11 +0,0 @@ -module Param { - S ::= Exp | Exp ";" S; - Exp ::= Id | Int | Bool; - Id ::= #rx"^[A-Za-z][A-Za-z0-9]*$"; - Int ::= #rx"^[0-9]+$" | Int "+" Int [left]; - Bool ::= "#true" | "#false"; - forall T. - T ::= "if" Bool "then" T "else" T; - forall T1 T2. - T2 ::= "let" x:Id "=" T1 { x:T1; T2 }; -} diff --git a/src/test-parse/TIL.es b/src/test-parse/TIL.es deleted file mode 100644 index 2deb91b..0000000 --- a/src/test-parse/TIL.es +++ /dev/null @@ -1,40 +0,0 @@ -module TIL { - Program ::= Stats; - Stats ::= Stat Stats | Stat; - Stat ::= Declaration | DeclarationTyped | Assign - | Block | IfThen | IfElse | While | For | ProcCall; - Declaration ::= "var" Id ";"; - DeclarationTyped ::= "var" Id ":" TILType ";"; - TILType ::= Id; - Assign ::= Id "::=" Exp ";"; - Block ::= "begin" Stats "end"; - IfThen ::= "if" Exp "then" Stats "end"; - IfElse ::= "if" Exp "then" Stats "else" Stats "end"; - While ::= "while" Exp "do" Stats "end"; - For ::= "for" Id "::=" Exp "to" Exp "do" Stats "end"; - ProcCall ::= Id "(" Exp ")" ";"; - Exp ::= Mul | Div | Mod | Add | Sub - | Lt | Gt | Leq | Geq | Equ | Neq - | And | Or | True | False - | Id | Int | String | FunCall - | "(" Exp ")"; - FunCall ::= Id "(" Exp ")"; - Mul ::= Exp "*" Exp; - Div ::= Exp "/" Exp; - Mod ::= Exp "%" Exp; - Add ::= Exp "+" Exp; - Sub ::= Exp "-" Exp; - Lt ::= Exp "<" Exp; - Gt ::= Exp ">" Exp; - Leq ::= Exp "<=" Exp; - Geq ::= Exp ">=" Exp; - Equ ::= Exp "=" Exp; - Neq ::= Exp "!=" Exp; - And ::= Exp "&" Exp; - Or ::= Exp "|" Exp; - True ::= "true"; - False ::= "false"; - Id ::= #rx"^[A-Za-z][A-Za-z0-9]*$"; - Int ::= #rx"^[0-9]+$"; - String ::= #rx"^[\"][^\"]*[\"]$"; -} diff --git a/src/test-parse/gemver.ast b/src/test-parse/gemver.ast deleted file mode 100644 index 6487878..0000000 --- a/src/test-parse/gemver.ast +++ /dev/null @@ -1,46 +0,0 @@ -((input - (VAR . "GEMVER") - (param_list - (param (VAR . "A") (type (orientation . "column"))) - (param_list - (param (VAR . "u1") (type . "vector")) - (param_list - (param (VAR . "u2") (type . "vector")) - (param_list - (param (VAR . "v1") (type . "vector")) - (param_list - (param (VAR . "v2") (type . "vector")) - (param_list - (param (VAR . "a") (type . "scalar")) - (param_list - (param (VAR . "b") (type . "scalar")) - (param_list - (param (VAR . "y") (type . "vector")) - (param_list (param (VAR . "z") (type . "vector"))))))))))) - (param_list - (param (VAR . "B") (type (orientation . "column"))) - (param_list - (param (VAR . "x") (type . "vector")) - (param_list (param (VAR . "z") (type . "vector"))))) - (prog - (prog - (prog - (stmt - (VAR . "B") - (expr - (expr - (expr (VAR . "A")) - (expr (expr (VAR . "u1")) (expr (expr (VAR . "v1"))))) - (expr (expr (VAR . "u2")) (expr (expr (VAR . "v2"))))))) - (stmt - (VAR . "x") - (expr - (expr - (expr (VAR . "b")) - (expr (expr (expr (expr (VAR . "B"))) (expr (VAR . "y"))))) - (expr (VAR . "z"))))) - (stmt - (VAR . "w") - (expr - (expr (VAR . "a")) - (expr (expr (expr (VAR . "B")) (expr (VAR . "x"))))))))) diff --git a/src/test-parse/gemver.es b/src/test-parse/gemver.es deleted file mode 100644 index 68228f9..0000000 --- a/src/test-parse/gemver.es +++ /dev/null @@ -1,16 +0,0 @@ -import BTO; - -GEMVER -in - A : column matrix, - u1 : vector, u2 : vector, v1 : vector, v2 : vector, - a : scalar, b : scalar, - y : vector, z : vector -out - B : column matrix, - x : vector, z : vector -{ - B = A + u1 * v1' + u2 * v2' - x = b * (B' * y) + z - w = a * (B * x) -} diff --git a/src/test-parse/if1.ast b/src/test-parse/if1.ast deleted file mode 100644 index ed39643..0000000 --- a/src/test-parse/if1.ast +++ /dev/null @@ -1,14 +0,0 @@ -((S - (Exp (Int (Bool . "#true") (Int . "3") (Int . "1"))) - (S - (Exp - (Int - (Bool . "#true") - (Int . "1") - (Int (Bool . "#false") (Int . "0") (Int . "4")))) - (S - (Exp - (Int - (Bool (Bool . "#false") (Bool . "#false") (Bool . "#true")) - (Int . "1") - (Int . "2"))))))) diff --git a/src/test-parse/if1.es b/src/test-parse/if1.es deleted file mode 100644 index 1c9e169..0000000 --- a/src/test-parse/if1.es +++ /dev/null @@ -1,5 +0,0 @@ -import Param; - -if #true then 3 else 1 ; -if #true then 1 else if #false then 0 else 4 ; -if if #false then #false else #true then 1 else 2 diff --git a/src/test-parse/lc.ast b/src/test-parse/lc.ast deleted file mode 100644 index 9e9ab98..0000000 --- a/src/test-parse/lc.ast +++ /dev/null @@ -1,21 +0,0 @@ -((S - (Stmt (Assign (Var . "id") (Term (Abs (Var . "x") (Term (Var . "x")))))) - (S - (Stmt - (Term - (Abs - (Var . "s") - (Term - (Abs - (Var . "z") - (Term - (Term - (App - (Term (App (Term (Var . "s")) (Term (Var . "s")))) - (Term (Var . "z")))))))))) - (S - (Stmt - (Assign - (Var . "tru") - (Term - (Abs (Var . "t") (Term (Abs (Var . "f") (Term (Var . "t")))))))))))) diff --git a/src/test-parse/lc.es b/src/test-parse/lc.es deleted file mode 100644 index c2403c9..0000000 --- a/src/test-parse/lc.es +++ /dev/null @@ -1,5 +0,0 @@ -import Lambda; - -id = lambda x. x; -lambda s. lambda z. (s s z); -tru = lambda t. lambda f. t; diff --git a/src/test-parse/let0.ast b/src/test-parse/let0.ast deleted file mode 100644 index 5b4e8b9..0000000 --- a/src/test-parse/let0.ast +++ /dev/null @@ -1,23 +0,0 @@ -((S - (Exp (Add (Exp (Id . "x")) (Exp (Int . "4")))) - (S - (Exp - (Let - (Id . "x") - (Exp (Int . "1")) - (Exp - (Add - (Exp (Add (Exp (Id . "x")) (Exp (Int . "5")))) - (Exp (Int . "2")))))) - (S - (Exp - (Let - (Id . "y") - (Exp - (Add - (Exp (Add (Exp (Id . "x")) (Exp (Int . "23")))) - (Exp (Int . "1")))) - (Exp - (Add - (Exp (Add (Exp (Id . "y")) (Exp (Id . "x")))) - (Exp (Id . "x")))))))))) diff --git a/src/test-parse/let0.es b/src/test-parse/let0.es deleted file mode 100644 index d545c1b..0000000 --- a/src/test-parse/let0.es +++ /dev/null @@ -1,5 +0,0 @@ -import LetExp; - -x + 4 -let x = 1 in x + 5 + 2 -let y = x + 23 + 1 in y + x + x diff --git a/src/test-parse/let1.ast b/src/test-parse/let1.ast deleted file mode 100644 index e5bb1bb..0000000 --- a/src/test-parse/let1.ast +++ /dev/null @@ -1,13 +0,0 @@ -((S - (Exp - (Int - (Id . "y") - (Int . "1") - (Int - (Int - (Int . "y") - (Int - (Id . "y") - (Bool . "#true") - (Int (Id . "z") (Int . "3") (Int (Int . "z") (Int . "2"))))) - (Int . "y")))))) diff --git a/src/test-parse/let1.es b/src/test-parse/let1.es deleted file mode 100644 index 85157c8..0000000 --- a/src/test-parse/let1.es +++ /dev/null @@ -1,3 +0,0 @@ -import Param; - -let y = 1 { y + let y = #true { let z = 3 { z + 2 } } + y } diff --git a/src/test-parse/mult.ast b/src/test-parse/mult.ast deleted file mode 100644 index dd50564..0000000 --- a/src/test-parse/mult.ast +++ /dev/null @@ -1,18 +0,0 @@ -((S - (Stmt - (Exp - (Matrix - (Matrix - (Matrix - (Matrix - (Matrix - (Matrix - (Matrix - (Matrix (Matrix (Matrix . "A") (Matrix . "A")) (Matrix . "A")) - (Matrix . "A")) - (Matrix . "A")) - (Matrix . "A")) - (Matrix . "A")) - (Matrix . "A")) - (Matrix . "A")) - (Matrix . "A")))))) diff --git a/src/test-parse/mult.es b/src/test-parse/mult.es deleted file mode 100644 index d0be9eb..0000000 --- a/src/test-parse/mult.es +++ /dev/null @@ -1,5 +0,0 @@ -import MA; - -declare A:Matrix, x:Vector, a:Scalar { - A * A * A * A * A * A * A * A * A * A; -} diff --git a/src/test-parse/prec1.ast b/src/test-parse/prec1.ast deleted file mode 100644 index 1d18fbd..0000000 --- a/src/test-parse/prec1.ast +++ /dev/null @@ -1,8 +0,0 @@ -((S - (Exp - (Add - (Exp - (Add - (Exp (Neg (Exp (Name . "A")))) - (Exp (Mul (Exp (Name . "B")) (Exp (Name . "C")))))) - (Exp (Name . "D")))))) diff --git a/src/test-parse/prec1.es b/src/test-parse/prec1.es deleted file mode 100644 index 5ac2b17..0000000 --- a/src/test-parse/prec1.es +++ /dev/null @@ -1,3 +0,0 @@ -import Arith1; - -- A + B * C + D diff --git a/src/test-parse/prec2.ast b/src/test-parse/prec2.ast deleted file mode 100644 index e18f277..0000000 --- a/src/test-parse/prec2.ast +++ /dev/null @@ -1,10 +0,0 @@ -((S - (Exp - (Neg - (Exp - (Add - (Exp - (Add - (Exp (Name . "A")) - (Exp (Mul (Exp (Name . "B")) (Exp (Name . "C")))))) - (Exp (Name . "D")))))))) diff --git a/src/test-parse/prec2.es b/src/test-parse/prec2.es deleted file mode 100644 index f896ddc..0000000 --- a/src/test-parse/prec2.es +++ /dev/null @@ -1,3 +0,0 @@ -import Arith2; - -- A + B * C + D diff --git a/src/test-parse/til-fact.ast b/src/test-parse/til-fact.ast deleted file mode 100644 index 915569e..0000000 --- a/src/test-parse/til-fact.ast +++ /dev/null @@ -1,38 +0,0 @@ -((Program - (Stats - (Stat (Declaration (Id . "n"))) - (Stats - (Stat - (Assign - (Id . "n") - (Exp (FunCall (Id . "readint") (Exp (String . "\"> \"")))))) - (Stats - (Stat (Declaration (Id . "x"))) - (Stats - (Stat (Declaration (Id . "fact"))) - (Stats - (Stat (Assign (Id . "fact") (Exp (Int . "1")))) - (Stats - (Stat - (For - (Id . "x") - (Exp (Int . "1")) - (Exp (Id . "n")) - (Stats - (Stat - (Assign - (Id . "fact") - (Exp (Mul (Exp (Id . "x")) (Exp (Id . "fact"))))))))) - (Stats - (Stat (ProcCall (Id . "write") (Exp (String . "\"factorial of \"")))) - (Stats - (Stat (ProcCall (Id . "writeint") (Exp (Id . "n")))) - (Stats - (Stat (ProcCall (Id . "write") (Exp (String . "\" is \"")))) - (Stats - (Stat (ProcCall (Id . "writeint") (Exp (Id . "fact")))) - (Stats - (Stat - (ProcCall - (Id . "write") - (Exp (String . "\"\n\""))))))))))))))))) diff --git a/src/test-parse/til-fact.es b/src/test-parse/til-fact.es deleted file mode 100644 index c059d67..0000000 --- a/src/test-parse/til-fact.es +++ /dev/null @@ -1,15 +0,0 @@ -import TIL; - -var n; -n ::= readint("> "); -var x; -var fact; -fact ::= 1; -for x ::= 1 to n do - fact ::= x * fact; -end -write("factorial of "); -writeint(n); -write(" is "); -writeint(fact); -write("\n"); diff --git a/src/test-parser.rkt b/src/test-parser.rkt deleted file mode 100644 index 11658c6..0000000 --- a/src/test-parser.rkt +++ /dev/null @@ -1,39 +0,0 @@ -;;;;;; test-parser.rkt - Test parse-file. -*- Mode: Racket -*- -;;;;;; Author: Erik Silkensen -;;;;;; Version: 10 Nov 2011 - -#lang racket - -(require "es.rkt") -(require "utils.rkt") - -(provide (all-defined-out) - parse-file/island parse-file/td-earley parse-file/bu-earley) - -(define (read-file filename) - (with-input-from-file filename (lambda () (read)))) - -(define (test-file filename [parse-file parse-file/island] [time? #f]) - (equal? (parse-file filename #f time?) - (read-file (string-append (filename-base filename) ".ast")))) - -(define (is-test-file? filename) - (let ([ext (filename-extension (string->path filename))]) - (and (string=? "es" (if ext (bytes->string/utf-8 ext) "")) - (let ([base (filename-base filename)]) - (file-exists? (string->path (format "~a.ast" base))))))) - -(define (test-dir dir [parse-file parse-file/island] [time? #f]) - (let loop ([fs (directory-list dir)] [fc 0] [pc 0]) - (if (null? fs) - (printf "---------~n~a/~a TESTS PASSED.~n" pc (+ fc pc)) - (let ([f (car fs)]) - (if (is-test-file? (format "~a/~a" dir f)) - (let ([filename (format "~a/~a" dir (path->string f))]) - (printf "~a: " f) - (let ([res (test-file filename parse-file time?)]) - (if res - (unless time? (printf "ok.~n")) - (printf " ~a test failed!~n" f)) - (loop (cdr fs) (if res fc (+ fc 1)) (if res (+ pc 1) pc)))) - (loop (cdr fs) fc pc)))))) diff --git a/src/utils.rkt b/src/utils.rkt deleted file mode 100644 index a0dc3ef..0000000 --- a/src/utils.rkt +++ /dev/null @@ -1,63 +0,0 @@ -;;;;;; utils.rkt - Utilities module. -*- Mode: Racket -*- -;;;;;; Author: Erik Silkensen -;;;;;; Version: 3 Sep 2012 - -#lang typed/racket/no-check - -(require srfi/13) ;; string library - -(provide (all-defined-out)) - -(: interned-gensym (Symbol -> Symbol)) -(define (interned-gensym base) - (string->symbol (symbol->string (gensym base)))) - -(: filename-base (String -> String)) -(define (filename-base filename) - (substring filename 0 (string-index-right filename #\.))) - -(: filename-dir (String -> String)) -(define (filename-dir filename) - (let ([cp (path->complete-path (string->path filename))]) - (let-values ([(base name must-be-dir?) (split-path cp)]) - (if (path? base) - (path->string base) - (error filename))))) - -(: mapcar (All (T) ((Listof (Pairof T Any)) -> (Listof T)))) -(define (mapcar lst) - (let loop ([lst lst] [ret '()]) - (if (null? lst) - (reverse ret) - (loop (cdr lst) (cons (caar lst) ret))))) - -(: flatten ((Listof Any) -> (Listof Any))) -(define (flatten lst) - (if (null? lst) - lst - (append (if (list? (car lst)) - (flatten (car lst)) - (list (car lst))) - (flatten (cdr lst))))) - -(: list1? (All (T) (T -> Boolean))) -(define (list1? obj) (listn? 1 obj)) - -(: list2? (All (T) (T -> Boolean))) -(define (list2? obj) (listn? 2 obj)) - -(: list3? (All (T) (T -> Boolean))) -(define (list3? obj) (listn? 3 obj)) - -(: list4? (All (T) (T -> Boolean))) -(define (list4? obj) (listn? 4 obj)) - -(: listn? (All (T) (Natural T -> Boolean))) -(define (listn? n obj) (and (list? obj) (= n (length obj)))) - -(: print-hash (All (S T) ((HashTable S T) -> Void))) -(define (print-hash h) - (hash-for-each h - (lambda (k v) - (printf " ~s => " k) - (pretty-print v))))