diff --git a/Makefile b/Makefile index e131814..412cd01 100644 --- a/Makefile +++ b/Makefile @@ -44,8 +44,8 @@ cs019-doc: setup: - raco setup --no-docs -P dyoo whalesong.plt 1 6 + raco setup --no-docs -P dyoo whalesong.plt 1 7 planet-link: - raco planet link dyoo whalesong.plt 1 6 . \ No newline at end of file + raco planet link dyoo whalesong.plt 1 7 . \ No newline at end of file diff --git a/lang/kernel.rkt b/lang/kernel.rkt index 6f86236..e2cd247 100644 --- a/lang/kernel.rkt +++ b/lang/kernel.rkt @@ -170,8 +170,6 @@ hash-remove equal-hash-code hash-count - hash-keys - hash-values ;; Kernel inlinable @@ -511,6 +509,8 @@ symbol->string hash-has-key? + hash-keys + hash-values ) diff --git a/lang/private/hash.rkt b/lang/private/hash.rkt index b41864e..2f5b15d 100644 --- a/lang/private/hash.rkt +++ b/lang/private/hash.rkt @@ -11,7 +11,7 @@ (if (null? keys) '() (cons (f (car keys) (hash-ref a-hash (car keys))) - (loop (rest keys)))))) + (loop (cdr keys)))))) (define (hash-for-each a-hash f) @@ -24,6 +24,6 @@ (void) (begin (f (car keys) (hash-ref a-hash (car keys))) - (loop (rest keys)))))) + (loop (cdr keys)))))) diff --git a/make-planet-archive.sh b/make-planet-archive.sh index 656f0ee..d6c2977 100755 --- a/make-planet-archive.sh +++ b/make-planet-archive.sh @@ -1,6 +1,6 @@ #!/bin/bash MAJOR=1 -MINOR=6 +MINOR=7 PROJNAME=whalesong diff --git a/tests/conform/expected0.txt b/tests/conform/expected0.txt deleted file mode 100644 index bb84d7d..0000000 --- a/tests/conform/expected0.txt +++ /dev/null @@ -1,5 +0,0 @@ -6 -> 26 -> 16 -16 -> 132 -> 30 -30 -> 374 -> 31 -31 -> 119 - ok. diff --git a/tests/conform/program0.sch b/tests/conform/program0.sch deleted file mode 100644 index 536293d..0000000 --- a/tests/conform/program0.sch +++ /dev/null @@ -1,516 +0,0 @@ -(let () - -;; (define (caar l) -;; (car (car l))) - -;; (define (map f l) -;; (if (null? l) -;; null -;; (cons (f (car l)) -;; (map f (cdr l))))) - -;; (define (for-each f l) -;; (if (null? l) -;; null -;; (begin (f (car l)) -;; (for-each f (cdr l))))) - -;; (define (memq x l) -;; (if (null? l) -;; #f -;; (if (eq? x (car l)) -;; l -;; (memq x (cdr l))))) - - -;; (define (assq x l) -;; (if (null? l) -;; #f -;; (if (eq? x (caar l)) -;; (car l) -;; (assq x (cdr l))))) - - -;; (define (length l) -;; (if (null? l) -;; 0 -;; (add1 (length (cdr l))))) - - -;; (define (append l1 l2) -;; (if (nullb? l1) -;; l2 -;; (cons (car l1) (append (cdr l1) l2)))) - - -(define vector-copy - (lambda (v) - (let ((length (vector-length v))) - (let ((result (make-vector length))) - ((letrec ((loop - (lambda (n) (vector-set! result n (vector-ref v n)) (if (= n length) v (loop (+ n '1)))))) - loop) - '0))))) -(define sort - (lambda (obj pred) - (letrec ((loop (lambda (l) (if (if (pair? l) (pair? (cdr l)) '#f) (split l '() '()) l))) - (split - (lambda (l one two) - (if (pair? l) (split (cdr l) two (cons (car l) one)) (merge (loop one) (loop two))))) - (merge - (lambda (one two) - (if (null? one) - (begin two) - (if (pred (car two) (car one)) - (begin (cons (car two) (merge (cdr two) one))) - (begin (cons (car one) (merge (cdr one) two)))))))) - (if (let ((or-part (pair? obj))) (if or-part or-part (null? obj))) - (begin (loop obj)) - (if (vector? obj) - (begin (sort! (vector-copy obj) pred)) - (begin (error '"sort: argument should be a list or vector" obj))))))) -(define sort! - (lambda (v pred) - (letrec ((sort-internal! - (lambda (vec temp low high) - (if (< low high) - (let ((middle (quotient (+ low high) '2))) - (let ((next (+ middle '1))) - (sort-internal! temp vec low middle) - (sort-internal! temp vec next high) - ((letrec ((loop - (lambda (p p1 p2) - (if (not (> p high)) - (if (> p1 middle) - (begin - (vector-set! vec p (vector-ref temp p2)) - (loop (+ p '1) p1 (+ p2 '1))) - (if (let ((or-part (> p2 high))) - (if or-part - or-part - (pred (vector-ref temp p1) (vector-ref temp p2)))) - (begin - (vector-set! vec p (vector-ref temp p1)) - (loop (+ p '1) (+ p1 '1) p2)) - (begin - (vector-set! vec p (vector-ref temp p2)) - (loop (+ p '1) p1 (+ p2 '1))))) - (void))))) - loop) - low - low - next))) - (void))))) - (if (not (vector? v)) (error '"sort!: argument not a vector" v) (void)) - (sort-internal! v (vector-copy v) '0 (- (vector-length v) '1)) - v))) -(define adjoin (lambda (element set) (if (memq element set) set (cons element set)))) -(define eliminate - (lambda (element set) - (if (null? set) - (begin set) - (if (eq? element (car set)) (begin (cdr set)) (begin (cons (car set) (eliminate element (cdr set)))))))) -(define intersect - (lambda (list1 list2) - ((letrec ((loop - (lambda (l) - (if (null? l) - (begin '()) - (if (memq (car l) list2) (begin (cons (car l) (loop (cdr l)))) (begin (loop (cdr l)))))))) - loop) - list1))) -(define union (lambda (list1 list2) (if (null? list1) list2 (union (cdr list1) (adjoin (car list1) list2))))) -(define make-internal-node vector) -(define internal-node-name (lambda (node) (vector-ref node '0))) -(define internal-node-green-edges (lambda (node) (vector-ref node '1))) -(define internal-node-red-edges (lambda (node) (vector-ref node '2))) -(define internal-node-blue-edges (lambda (node) (vector-ref node '3))) -(define set-internal-node-name! (lambda (node name) (vector-set! node '0 name))) -(define set-internal-node-green-edges! (lambda (node edges) (vector-set! node '1 edges))) -(define set-internal-node-red-edges! (lambda (node edges) (vector-set! node '2 edges))) -(define set-internal-node-blue-edges! (lambda (node edges) (vector-set! node '3 edges))) -(define make-node - (lambda (name blue-edges) - (let ((name (if (symbol? name) (symbol->string name) name)) - (blue-edges (if (null? blue-edges) 'NOT-A-NODE-YET (car blue-edges)))) - (make-internal-node name '() '() blue-edges)))) -(define copy-node (lambda (node) (make-internal-node (name node) '() '() (blue-edges node)))) -(define name internal-node-name) -(define make-edge-getter - (lambda (selector) - (lambda (node) - (if (let ((or-part (none-node? node))) (if or-part or-part (any-node? node))) - (error '"Can't get edges from the ANY or NONE nodes") - (selector node))))) -(define red-edges (make-edge-getter internal-node-red-edges)) -(define green-edges (make-edge-getter internal-node-green-edges)) -(define blue-edges (make-edge-getter internal-node-blue-edges)) -(define make-edge-setter - (lambda (mutator!) - (lambda (node value) - (if (any-node? node) - (begin (error '"Can't set edges from the ANY node")) - (if (none-node? node) (begin 'OK) (begin (mutator! node value))))))) -(define set-red-edges! (make-edge-setter set-internal-node-red-edges!)) -(define set-green-edges! (make-edge-setter set-internal-node-green-edges!)) -(define set-blue-edges! (make-edge-setter set-internal-node-blue-edges!)) -(define make-blue-edge vector) -(define blue-edge-operation (lambda (edge) (vector-ref edge '0))) -(define blue-edge-arg-node (lambda (edge) (vector-ref edge '1))) -(define blue-edge-res-node (lambda (edge) (vector-ref edge '2))) -(define set-blue-edge-operation! (lambda (edge value) (vector-set! edge '0 value))) -(define set-blue-edge-arg-node! (lambda (edge value) (vector-set! edge '1 value))) -(define set-blue-edge-res-node! (lambda (edge value) (vector-set! edge '2 value))) -(define operation blue-edge-operation) -(define arg-node blue-edge-arg-node) -(define res-node blue-edge-res-node) -(define set-arg-node! set-blue-edge-arg-node!) -(define set-res-node! set-blue-edge-res-node!) -(define lookup-op - (lambda (op node) - ((letrec ((loop - (lambda (edges) - (if (null? edges) - (begin '()) - (if (eq? op (operation (car edges))) (begin (car edges)) (begin (loop (cdr edges)))))))) - loop) - (blue-edges node)))) -(define has-op? (lambda (op node) (not (null? (lookup-op op node))))) -(define make-internal-graph vector) -(define internal-graph-nodes (lambda (graph) (vector-ref graph '0))) -(define internal-graph-already-met (lambda (graph) (vector-ref graph '1))) -(define internal-graph-already-joined (lambda (graph) (vector-ref graph '2))) -(define set-internal-graph-nodes! (lambda (graph nodes) (vector-set! graph '0 nodes))) -(define make-graph (lambda (nodes) (make-internal-graph nodes (make-empty-table) (make-empty-table)))) -(define graph-nodes internal-graph-nodes) -(define already-met internal-graph-already-met) -(define already-joined internal-graph-already-joined) -(define add-graph-nodes! - (lambda (graph nodes) (set-internal-graph-nodes! graph (cons nodes (graph-nodes graph))))) -(define copy-graph - (lambda (g) - (letrec ((copy-list (lambda (l) (vector->list (list->vector l))))) - (make-internal-graph (copy-list (graph-nodes g)) (already-met g) (already-joined g))))) -(define clean-graph - (lambda (g) - (letrec ((clean-node - (lambda (node) - (if (not (let ((or-part (any-node? node))) (if or-part or-part (none-node? node)))) - (begin (set-green-edges! node '()) (set-red-edges! node '())) - (void))))) - (for-each clean-node (graph-nodes g)) - g))) -(define canonicalize-graph - (lambda (graph classes) - (letrec ((fix - (lambda (node) - (letrec ((fix-set - (lambda (object selector mutator) - (mutator - object - (map - (lambda (node) (find-canonical-representative node classes)) - (selector object)))))) - (if (not (let ((or-part (none-node? node))) (if or-part or-part (any-node? node)))) - (begin - (fix-set node green-edges set-green-edges!) - (fix-set node red-edges set-red-edges!) - (for-each - (lambda (blue-edge) - (set-arg-node! blue-edge (find-canonical-representative (arg-node blue-edge) classes)) - (set-res-node! blue-edge (find-canonical-representative (res-node blue-edge) classes))) - (blue-edges node))) - (void)) - node))) - (fix-table - (lambda (table) - (letrec ((canonical? (lambda (node) (eq? node (find-canonical-representative node classes)))) - (filter-and-fix - (lambda (predicate-fn update-fn list) - ((letrec ((loop - (lambda (list) - (if (null? list) - (begin '()) - (if (predicate-fn (car list)) - (begin (cons (update-fn (car list)) (loop (cdr list)))) - (begin (loop (cdr list)))))))) - loop) - list))) - (fix-line - (lambda (line) - (filter-and-fix - (lambda (entry) (canonical? (car entry))) - (lambda (entry) - (cons (car entry) (find-canonical-representative (cdr entry) classes))) - line)))) - (if (null? table) - '() - (cons - (car table) - (filter-and-fix - (lambda (entry) (canonical? (car entry))) - (lambda (entry) (cons (car entry) (fix-line (cdr entry)))) - (cdr table)))))))) - (make-internal-graph - (map (lambda (class) (fix (car class))) classes) - (fix-table (already-met graph)) - (fix-table (already-joined graph)))))) - - - -(define none-node (make-node 'none '(#t))) -(define none-node? (lambda (node) (eq? node none-node))) -(define any-node (make-node 'any '(()))) -(define any-node? (lambda (node) (eq? node any-node))) -(define green-edge? - (lambda (from-node to-node) - (if (any-node? from-node) - (begin '#f) - (if (none-node? from-node) - (begin '#t) - (if (memq to-node (green-edges from-node)) (begin '#t) (begin '#f)))))) -(define red-edge? - (lambda (from-node to-node) - (if (any-node? from-node) - (begin '#f) - (if (none-node? from-node) - (begin '#t) - (if (memq to-node (red-edges from-node)) (begin '#t) (begin '#f)))))) -(define sig - (let ((none-comma-any (cons none-node any-node))) - (lambda (op node) - (let ((the-edge (lookup-op op node))) - (if (not (null? the-edge)) (cons (arg-node the-edge) (res-node the-edge)) none-comma-any))))) -(define arg (lambda (pair) (car pair))) -(define res (lambda (pair) (cdr pair))) -(define conforms? - (lambda (t1 t2) - (letrec ((nodes-with-red-edges-out '()) - (add-red-edge! - (lambda (from-node to-node) - (set-red-edges! from-node (adjoin to-node (red-edges from-node))) - (set! nodes-with-red-edges-out (adjoin from-node nodes-with-red-edges-out)))) - (greenify-red-edges! - (lambda (from-node) - (set-green-edges! from-node (append (red-edges from-node) (green-edges from-node))) - (set-red-edges! from-node '()))) - (delete-red-edges! (lambda (from-node) (set-red-edges! from-node '()))) - (does-conform - (lambda (t1 t2) - (if (let ((or-part (none-node? t1))) (if or-part or-part (any-node? t2))) - (begin '#t) - (if (let ((or-part (any-node? t1))) (if or-part or-part (none-node? t2))) - (begin '#f) - (if (green-edge? t1 t2) - (begin '#t) - (if (red-edge? t1 t2) - (begin '#t) - (begin - (add-red-edge! t1 t2) - ((letrec ((loop - (lambda (blues) - (if (null? blues) - '#t - (let ((current-edge (car blues))) - (let ((phi (operation current-edge))) - (if (has-op? phi t1) - (if (does-conform (res (sig phi t1)) (res (sig phi t2))) - (if (does-conform (arg (sig phi t2)) (arg (sig phi t1))) - (loop (cdr blues)) - '#f) - '#f) - '#f))))))) - loop) - (blue-edges t2)))))))))) - (let ((result (does-conform t1 t2))) - (for-each (if result greenify-red-edges! delete-red-edges!) nodes-with-red-edges-out) - result)))) -(define equivalent? (lambda (a b) (if (conforms? a b) (conforms? b a) '#f))) -(define classify - (lambda (nodes) - ((letrec ((node-loop - (lambda (classes nodes) - (if (null? nodes) - (map - (lambda (class) - (sort - class - (lambda (node1 node2) (< (string-length (name node1)) (string-length (name node2)))))) - classes) - (let ((this-node (car nodes))) - (letrec ((add-node - (lambda (classes) - (if (null? classes) - (begin (list (list this-node))) - (if (equivalent? this-node (caar classes)) - (begin (cons (cons this-node (car classes)) (cdr classes))) - (begin (cons (car classes) (add-node (cdr classes))))))))) - (node-loop (add-node classes) (cdr nodes)))))))) - node-loop) - '() - nodes))) -(define find-canonical-representative - (lambda (element classification) - ((letrec ((loop - (lambda (classes) - (if (null? classes) - (begin (error '"Can't classify" element)) - (if (memq element (car classes)) (begin (car (car classes))) (begin (loop (cdr classes)))))))) - loop) - classification))) -(define reduce - (lambda (graph) (let ((classes (classify (graph-nodes graph)))) (canonicalize-graph graph classes)))) -(define make-empty-table (lambda () (list 'TABLE))) -(define lookup - (lambda (table x y) - (let ((one (assq x (cdr table)))) (if one (let ((two (assq y (cdr one)))) (if two (cdr two) '#f)) '#f)))) -(define insert! - (lambda (table x y value) - (letrec ((make-singleton-table (lambda (x y) (list (cons x y))))) - (let ((one (assq x (cdr table)))) - (if one - (set-cdr! one (cons (cons y value) (cdr one))) - (set-cdr! table (cons (cons x (make-singleton-table y value)) (cdr table)))))))) -(define blue-edge-operate - (lambda (arg-fn res-fn graph op sig1 sig2) - (make-blue-edge op (arg-fn graph (arg sig1) (arg sig2)) (res-fn graph (res sig1) (res sig2))))) - - - - -(define meet - (lambda (graph node1 node2) - (if (eq? node1 node2) - (begin node1) - (if (let ((or-part (any-node? node1))) (if or-part or-part (any-node? node2))) - (begin any-node) - (if (none-node? node1) - (begin node2) - (if (none-node? node2) - (begin node1) - (let ((c17352 (lookup (already-met graph) node1 node2))) - (if c17352 - c17352 - (if (conforms? node1 node2) - (begin node2) - (if (conforms? node2 node1) - (begin node1) - (begin - (let ((result (make-node (string-append '"(" (name node1) '" ^ " (name node2) '")") '()))) - (add-graph-nodes! graph result) - (insert! (already-met graph) node1 node2 result) - (set-blue-edges! - result - (map - (lambda (op) (blue-edge-operate join meet graph op (sig op node1) (sig op node2))) - (intersect (map operation (blue-edges node1)) (map operation (blue-edges node2))))) - result)))))))))))) -(define join - (lambda (graph node1 node2) - (if (eq? node1 node2) - (begin node1) - (if (any-node? node1) - (begin node2) - (if (any-node? node2) - (begin node1) - (if (let ((or-part (none-node? node1))) (if or-part or-part (none-node? node2))) - (begin none-node) - (let ((c17353 (lookup (already-joined graph) node1 node2))) - (if c17353 - c17353 - (if (conforms? node1 node2) - (begin node1) - (if (conforms? node2 node1) - (begin node2) - (begin - (let ((result (make-node (string-append '"(" (name node1) '" v " (name node2) '")") '()))) - (add-graph-nodes! graph result) - (insert! (already-joined graph) node1 node2 result) - (set-blue-edges! - result - (map - (lambda (op) (blue-edge-operate meet join graph op (sig op node1) (sig op node2))) - (union (map operation (blue-edges node1)) (map operation (blue-edges node2))))) - result)))))))))))) -(define make-lattice - (lambda (g print?) - (letrec ((step - (lambda (g) - (let ((copy (copy-graph g))) - (let ((nodes (graph-nodes copy))) - (for-each - (lambda (first) - (for-each (lambda (second) (meet copy first second) (join copy first second)) nodes)) - nodes) - copy)))) - (loop - (lambda (g count) - (if print? (display count) (void)) - (let ((lattice (step g))) - (if print? (begin (display '" -> ") (display (length (graph-nodes lattice)))) (void)) - (let ((new-g (reduce lattice))) - (let ((new-count (length (graph-nodes new-g)))) - (if (= new-count count) - (begin (if print? (newline) (void)) new-g) - (begin - (if print? (begin (display '" -> ") (display new-count) (newline)) (void)) - (loop new-g new-count))))))))) - (let ((graph (make-graph (adjoin any-node (adjoin none-node (graph-nodes (clean-graph g))))))) - (loop graph (length (graph-nodes graph))))))) -(define a '()) -(define b '()) -(define c '()) -(define d '()) -(define reset - (lambda () - (set! a (make-node 'a '())) - (set! b (make-node 'b '())) - (set-blue-edges! a (list (make-blue-edge 'phi any-node b))) - (set-blue-edges! b (list (make-blue-edge 'phi any-node a) (make-blue-edge 'theta any-node b))) - (set! c (make-node '"c" '())) - (set! d (make-node '"d" '())) - (set-blue-edges! c (list (make-blue-edge 'theta any-node b))) - (set-blue-edges! d (list (make-blue-edge 'phi any-node c) (make-blue-edge 'theta any-node d))) - '(made a b c d))) -(define test - (lambda () (reset) (map name (graph-nodes (make-lattice (make-graph (list a b c d any-node none-node)) '#t))))) -(define go - (lambda () - (reset) - (let ((result - '("(((b v d) ^ a) v c)" - "(c ^ d)" - "(b v (a ^ d))" - "((a v d) ^ b)" - "(b v d)" - "(b ^ (a v c))" - "(a v (c ^ d))" - "((b v d) ^ a)" - "(c v (a v d))" - "(a v c)" - "(d v (b ^ (a v c)))" - "(d ^ (a v c))" - "((a ^ d) v c)" - "((a ^ b) v d)" - "(((a v d) ^ b) v (a ^ d))" - "(b ^ d)" - "(b v (a v d))" - "(a ^ c)" - "(b ^ (c v d))" - "(a ^ b)" - "(a v b)" - "((a ^ d) ^ b)" - "(a ^ d)" - "(a v d)" - "d" - "(c v d)" - "a" - "b" - "c" - "any" - "none"))) - (if (equal? (test) result) (display '" ok.") (display '" um.")) - (newline)))) - - -(void ((letrec ((loop (lambda (n) (if (zero? n) 'done (begin (go) (loop (- n '1))))))) loop) 1))) \ No newline at end of file diff --git a/tests/earley/earley.rkt b/tests/earley/earley.rkt deleted file mode 100644 index 7ac0cf9..0000000 --- a/tests/earley/earley.rkt +++ /dev/null @@ -1,826 +0,0 @@ -#lang planet dyoo/whalesong -(begin - (define make-parser - (lambda (grammar lexer) - (letrec ((non-terminals - (lambda (grammar) - (letrec ((add-nt (lambda (nt nts) (if (member nt nts) nts (cons nt nts))))) - ((letrec ((def-loop - (lambda (defs nts) - (if (pair? defs) - (let ((def (car defs))) - (let ((head (car def))) - ((letrec ((rule-loop - (lambda (rules nts) - (if (pair? rules) - (let ((rule (car rules))) - ((letrec ((loop - (lambda (l nts) - (if (pair? l) - (let ((nt (car l))) - (loop (cdr l) (add-nt nt nts))) - (rule-loop (cdr rules) nts))))) - loop) - rule - nts)) - (def-loop (cdr defs) nts))))) - rule-loop) - (cdr def) - (add-nt head nts)))) - (list->vector (reverse nts)))))) - def-loop) - grammar - '())))) - (ind - (lambda (nt nts) - ((letrec ((loop - (lambda (i) - (if (>= i '0) (if (equal? (vector-ref nts i) nt) i (loop (- i '1))) '#f)))) - loop) - (- (vector-length nts) '1)))) - (nb-configurations - (lambda (grammar) - ((letrec ((def-loop - (lambda (defs nb-confs) - (if (pair? defs) - (let ((def (car defs))) - ((letrec ((rule-loop - (lambda (rules nb-confs) - (if (pair? rules) - (let ((rule (car rules))) - ((letrec ((loop - (lambda (l nb-confs) - (if (pair? l) - (loop (cdr l) (+ nb-confs '1)) - (rule-loop (cdr rules) (+ nb-confs '1)))))) - loop) - rule - nb-confs)) - (def-loop (cdr defs) nb-confs))))) - rule-loop) - (cdr def) - nb-confs)) - nb-confs)))) - def-loop) - grammar - '0)))) - (let ((nts (non-terminals grammar))) - (let ((nb-nts (vector-length nts))) - (let ((nb-confs (+ (nb-configurations grammar) nb-nts))) - (let ((starters (make-vector nb-nts '()))) - (let ((enders (make-vector nb-nts '()))) - (let ((predictors (make-vector nb-nts '()))) - (let ((steps (make-vector nb-confs '#f))) - (let ((names (make-vector nb-confs '#f))) - (letrec ((setup-tables - (lambda (grammar nts starters enders predictors steps names) - (letrec ((add-conf - (lambda (conf nt nts class) - (let ((i (ind nt nts))) - (vector-set! class i (cons conf (vector-ref class i))))))) - (let ((nb-nts (vector-length nts))) - ((letrec ((nt-loop - (lambda (i) - (if (>= i '0) - (begin - (vector-set! steps i (- i nb-nts)) - (vector-set! names i (list (vector-ref nts i) '0)) - (vector-set! enders i (list i)) - (nt-loop (- i '1))) - '#f)))) - nt-loop) - (- nb-nts '1)) - ((letrec ((def-loop - (lambda (defs conf) - (if (pair? defs) - (let ((def (car defs))) - (let ((head (car def))) - ((letrec ((rule-loop - (lambda (rules conf rule-num) - (if (pair? rules) - (let ((rule (car rules))) - (vector-set! - names - conf - (list head rule-num)) - (add-conf conf head nts starters) - ((letrec ((loop - (lambda (l conf) - (if (pair? l) - (let ((nt (car l))) - (vector-set! - steps - conf - (ind nt nts)) - (add-conf - conf - nt - nts - predictors) - (loop - (cdr l) - (+ conf '1))) - (begin - (vector-set! - steps - conf - (- - (ind head nts) - nb-nts)) - (add-conf - conf - head - nts - enders) - (rule-loop - (cdr rules) - (+ conf '1) - (+ rule-num '1))))))) - loop) - rule - conf)) - (def-loop (cdr defs) conf))))) - rule-loop) - (cdr def) - conf - '1))) - '#f)))) - def-loop) - grammar - (vector-length nts))))))) - (setup-tables grammar nts starters enders predictors steps names) - (let ((parser-descr (vector lexer nts starters enders predictors steps names))) - (lambda (input) - (letrec ((ind - (lambda (nt nts) - ((letrec ((loop - (lambda (i) - (if (>= i '0) - (if (equal? (vector-ref nts i) nt) i (loop (- i '1))) - '#f)))) - loop) - (- (vector-length nts) '1)))) - (comp-tok - (lambda (tok nts) - ((letrec ((loop - (lambda (l1 l2) - (if (pair? l1) - (let ((i (ind (car l1) nts))) - (if i (loop (cdr l1) (cons i l2)) (loop (cdr l1) l2))) - (cons (car tok) (reverse l2)))))) - loop) - (cdr tok) - '()))) - (input->tokens - (lambda (input lexer nts) - (list->vector (map (lambda (tok) (comp-tok tok nts)) (lexer input))))) - (make-states - (lambda (nb-toks nb-confs) - (let ((states (make-vector (+ nb-toks '1) '#f))) - ((letrec ((loop - (lambda (i) - (if (>= i '0) - (let ((v (make-vector (+ nb-confs '1) '#f))) - (vector-set! v '0 '-1) - (vector-set! states i v) - (loop (- i '1))) - states)))) - loop) - nb-toks)))) - (conf-set-get (lambda (state conf) (vector-ref state (+ conf '1)))) - (conf-set-get* - (lambda (state state-num conf) - (let ((conf-set (conf-set-get state conf))) - (if conf-set - conf-set - (let ((conf-set (make-vector (+ state-num '6) '#f))) - (vector-set! conf-set '1 '-3) - (vector-set! conf-set '2 '-1) - (vector-set! conf-set '3 '-1) - (vector-set! conf-set '4 '-1) - (vector-set! state (+ conf '1) conf-set) - conf-set))))) - (conf-set-merge-new! - (lambda (conf-set) - (vector-set! - conf-set - (+ (vector-ref conf-set '1) '5) - (vector-ref conf-set '4)) - (vector-set! conf-set '1 (vector-ref conf-set '3)) - (vector-set! conf-set '3 '-1) - (vector-set! conf-set '4 '-1))) - (conf-set-head (lambda (conf-set) (vector-ref conf-set '2))) - (conf-set-next (lambda (conf-set i) (vector-ref conf-set (+ i '5)))) - (conf-set-member? - (lambda (state conf i) - (let ((conf-set (vector-ref state (+ conf '1)))) - (if conf-set (conf-set-next conf-set i) '#f)))) - (conf-set-adjoin - (lambda (state conf-set conf i) - (let ((tail (vector-ref conf-set '3))) - (vector-set! conf-set (+ i '5) '-1) - (vector-set! conf-set (+ tail '5) i) - (vector-set! conf-set '3 i) - (if (< tail '0) - (begin - (vector-set! conf-set '0 (vector-ref state '0)) - (vector-set! state '0 conf)) - '#f)))) - (conf-set-adjoin* - (lambda (states state-num l i) - (let ((state (vector-ref states state-num))) - ((letrec ((loop - (lambda (l1) - (if (pair? l1) - (let ((conf (car l1))) - (let ((conf-set (conf-set-get* state state-num conf))) - (if (not (conf-set-next conf-set i)) - (begin - (conf-set-adjoin state conf-set conf i) - (loop (cdr l1))) - (loop (cdr l1))))) - '#f)))) - loop) - l)))) - (conf-set-adjoin** - (lambda (states states* state-num conf i) - (let ((state (vector-ref states state-num))) - (if (conf-set-member? state conf i) - (let ((state* (vector-ref states* state-num))) - (let ((conf-set* (conf-set-get* state* state-num conf))) - (if (not (conf-set-next conf-set* i)) - (conf-set-adjoin state* conf-set* conf i) - '#f) - '#t)) - '#f)))) - (conf-set-union - (lambda (state conf-set conf other-set) - ((letrec ((loop - (lambda (i) - (if (>= i '0) - (if (not (conf-set-next conf-set i)) - (begin - (conf-set-adjoin state conf-set conf i) - (loop (conf-set-next other-set i))) - (loop (conf-set-next other-set i))) - '#f)))) - loop) - (conf-set-head other-set)))) - (forw - (lambda (states state-num starters enders predictors steps nts) - (letrec ((predict - (lambda (state state-num conf-set conf nt starters enders) - ((letrec ((loop1 - (lambda (l) - (if (pair? l) - (let ((starter (car l))) - (let ((starter-set - (conf-set-get* - state - state-num - starter))) - (if (not - (conf-set-next - starter-set - state-num)) - (begin - (conf-set-adjoin - state - starter-set - starter - state-num) - (loop1 (cdr l))) - (loop1 (cdr l))))) - '#f)))) - loop1) - (vector-ref starters nt)) - ((letrec ((loop2 - (lambda (l) - (if (pair? l) - (let ((ender (car l))) - (if (conf-set-member? state ender state-num) - (let ((next (+ conf '1))) - (let ((next-set - (conf-set-get* - state - state-num - next))) - (conf-set-union - state - next-set - next - conf-set) - (loop2 (cdr l)))) - (loop2 (cdr l)))) - '#f)))) - loop2) - (vector-ref enders nt)))) - (reduce - (lambda (states state state-num conf-set head preds) - ((letrec ((loop1 - (lambda (l) - (if (pair? l) - (let ((pred (car l))) - ((letrec ((loop2 - (lambda (i) - (if (>= i '0) - (let ((pred-set - (conf-set-get - (vector-ref states i) - pred))) - (if pred-set - (let ((next (+ pred '1))) - (let ((next-set - (conf-set-get* - state - state-num - next))) - (conf-set-union - state - next-set - next - pred-set))) - '#f) - (loop2 - (conf-set-next - conf-set - i))) - (loop1 (cdr l)))))) - loop2) - head)) - '#f)))) - loop1) - preds)))) - (let ((state (vector-ref states state-num)) - (nb-nts (vector-length nts))) - ((letrec ((loop - (lambda () - (let ((conf (vector-ref state '0))) - (if (>= conf '0) - (let ((step (vector-ref steps conf))) - (let ((conf-set (vector-ref state (+ conf '1)))) - (let ((head (vector-ref conf-set '4))) - (vector-set! - state - '0 - (vector-ref conf-set '0)) - (conf-set-merge-new! conf-set) - (if (>= step '0) - (predict - state - state-num - conf-set - conf - step - starters - enders) - (let ((preds - (vector-ref - predictors - (+ step nb-nts)))) - (reduce - states - state - state-num - conf-set - head - preds))) - (loop)))) - '#f))))) - loop)))))) - (forward - (lambda (starters enders predictors steps nts toks) - (let ((nb-toks (vector-length toks))) - (let ((nb-confs (vector-length steps))) - (let ((states (make-states nb-toks nb-confs))) - (let ((goal-starters (vector-ref starters '0))) - (conf-set-adjoin* states '0 goal-starters '0) - (forw states '0 starters enders predictors steps nts) - ((letrec ((loop - (lambda (i) - (if (< i nb-toks) - (let ((tok-nts (cdr (vector-ref toks i)))) - (conf-set-adjoin* states (+ i '1) tok-nts i) - (forw - states - (+ i '1) - starters - enders - predictors - steps - nts) - (loop (+ i '1))) - '#f)))) - loop) - '0) - states)))))) - (produce - (lambda (conf i j enders steps toks states states* nb-nts) - (let ((prev (- conf '1))) - (if (if (>= conf nb-nts) (>= (vector-ref steps prev) '0) '#f) - ((letrec ((loop1 - (lambda (l) - (if (pair? l) - (let ((ender (car l))) - (let ((ender-set - (conf-set-get (vector-ref states j) ender))) - (if ender-set - ((letrec ((loop2 - (lambda (k) - (if (>= k '0) - (begin - (if (>= k i) - (if (conf-set-adjoin** - states - states* - k - prev - i) - (conf-set-adjoin** - states - states* - j - ender - k) - '#f) - '#f) - (loop2 - (conf-set-next ender-set k))) - (loop1 (cdr l)))))) - loop2) - (conf-set-head ender-set)) - (loop1 (cdr l))))) - '#f)))) - loop1) - (vector-ref enders (vector-ref steps prev))) - '#f)))) - (back - (lambda (states states* state-num enders steps nb-nts toks) - (let ((state* (vector-ref states* state-num))) - ((letrec ((loop1 - (lambda () - (let ((conf (vector-ref state* '0))) - (if (>= conf '0) - (let ((conf-set (vector-ref state* (+ conf '1)))) - (let ((head (vector-ref conf-set '4))) - (vector-set! state* '0 (vector-ref conf-set '0)) - (conf-set-merge-new! conf-set) - ((letrec ((loop2 - (lambda (i) - (if (>= i '0) - (begin - (produce - conf - i - state-num - enders - steps - toks - states - states* - nb-nts) - (loop2 - (conf-set-next conf-set i))) - (loop1))))) - loop2) - head))) - '#f))))) - loop1))))) - (backward - (lambda (states enders steps nts toks) - (let ((nb-toks (vector-length toks))) - (let ((nb-confs (vector-length steps))) - (let ((nb-nts (vector-length nts))) - (let ((states* (make-states nb-toks nb-confs))) - (let ((goal-enders (vector-ref enders '0))) - ((letrec ((loop1 - (lambda (l) - (if (pair? l) - (let ((conf (car l))) - (conf-set-adjoin** - states - states* - nb-toks - conf - '0) - (loop1 (cdr l))) - '#f)))) - loop1) - goal-enders) - ((letrec ((loop2 - (lambda (i) - (if (>= i '0) - (begin - (back - states - states* - i - enders - steps - nb-nts - toks) - (loop2 (- i '1))) - '#f)))) - loop2) - nb-toks) - states*))))))) - (parsed? - (lambda (nt i j nts enders states) - (let ((nt* (ind nt nts))) - (if nt* - (let ((nb-nts (vector-length nts))) - ((letrec ((loop - (lambda (l) - (if (pair? l) - (let ((conf (car l))) - (if (conf-set-member? - (vector-ref states j) - conf - i) - '#t - (loop (cdr l)))) - '#f)))) - loop) - (vector-ref enders nt*))) - '#f)))) - (deriv-trees - (lambda (conf i j enders steps names toks states nb-nts) - (let ((name (vector-ref names conf))) - (if name - (if (< conf nb-nts) - (list (list name (car (vector-ref toks i)))) - (list (list name))) - (let ((prev (- conf '1))) - ((letrec ((loop1 - (lambda (l1 l2) - (if (pair? l1) - (let ((ender (car l1))) - (let ((ender-set - (conf-set-get - (vector-ref states j) - ender))) - (if ender-set - ((letrec ((loop2 - (lambda (k l2) - (if (>= k '0) - (if (if (>= k i) - (conf-set-member? - (vector-ref states k) - prev - i) - '#f) - (let ((prev-trees - (deriv-trees - prev - i - k - enders - steps - names - toks - states - nb-nts)) - (ender-trees - (deriv-trees - ender - k - j - enders - steps - names - toks - states - nb-nts))) - ((letrec ((loop3 - (lambda (l3 l2) - (if (pair? l3) - (let ((ender-tree - (list - (car - l3)))) - ((letrec ((loop4 - (lambda (l4 - l2) - (if (pair? - l4) - (loop4 - (cdr - l4) - (cons - (append - (car - l4) - ender-tree) - l2)) - (loop3 - (cdr - l3) - l2))))) - loop4) - prev-trees - l2)) - (loop2 - (conf-set-next - ender-set - k) - l2))))) - loop3) - ender-trees - l2)) - (loop2 - (conf-set-next ender-set k) - l2)) - (loop1 (cdr l1) l2))))) - loop2) - (conf-set-head ender-set) - l2) - (loop1 (cdr l1) l2)))) - l2)))) - loop1) - (vector-ref enders (vector-ref steps prev)) - '())))))) - (deriv-trees* - (lambda (nt i j nts enders steps names toks states) - (let ((nt* (ind nt nts))) - (if nt* - (let ((nb-nts (vector-length nts))) - ((letrec ((loop - (lambda (l trees) - (if (pair? l) - (let ((conf (car l))) - (if (conf-set-member? - (vector-ref states j) - conf - i) - (loop - (cdr l) - (append - (deriv-trees - conf - i - j - enders - steps - names - toks - states - nb-nts) - trees)) - (loop (cdr l) trees))) - trees)))) - loop) - (vector-ref enders nt*) - '())) - '#f)))) - (nb-deriv-trees - (lambda (conf i j enders steps toks states nb-nts) - (let ((prev (- conf '1))) - (if (let ((or-part (< conf nb-nts))) - (if or-part or-part (< (vector-ref steps prev) '0))) - '1 - ((letrec ((loop1 - (lambda (l n) - (if (pair? l) - (let ((ender (car l))) - (let ((ender-set - (conf-set-get (vector-ref states j) ender))) - (if ender-set - ((letrec ((loop2 - (lambda (k n) - (if (>= k '0) - (if (if (>= k i) - (conf-set-member? - (vector-ref states k) - prev - i) - '#f) - (let ((nb-prev-trees - (nb-deriv-trees - prev - i - k - enders - steps - toks - states - nb-nts)) - (nb-ender-trees - (nb-deriv-trees - ender - k - j - enders - steps - toks - states - nb-nts))) - (loop2 - (conf-set-next ender-set k) - (+ - n - (* - nb-prev-trees - nb-ender-trees)))) - (loop2 - (conf-set-next ender-set k) - n)) - (loop1 (cdr l) n))))) - loop2) - (conf-set-head ender-set) - n) - (loop1 (cdr l) n)))) - n)))) - loop1) - (vector-ref enders (vector-ref steps prev)) - '0))))) - (nb-deriv-trees* - (lambda (nt i j nts enders steps toks states) - (let ((nt* (ind nt nts))) - (if nt* - (let ((nb-nts (vector-length nts))) - ((letrec ((loop - (lambda (l nb-trees) - (if (pair? l) - (let ((conf (car l))) - (if (conf-set-member? - (vector-ref states j) - conf - i) - (loop - (cdr l) - (+ - (nb-deriv-trees - conf - i - j - enders - steps - toks - states - nb-nts) - nb-trees)) - (loop (cdr l) nb-trees))) - nb-trees)))) - loop) - (vector-ref enders nt*) - '0)) - '#f))))) - (let ((lexer (vector-ref parser-descr '0))) - (let ((nts (vector-ref parser-descr '1))) - (let ((starters (vector-ref parser-descr '2))) - (let ((enders (vector-ref parser-descr '3))) - (let ((predictors (vector-ref parser-descr '4))) - (let ((steps (vector-ref parser-descr '5))) - (let ((names (vector-ref parser-descr '6))) - (let ((toks (input->tokens input lexer nts))) - (vector - nts - starters - enders - predictors - steps - names - toks - (backward - (forward starters enders predictors steps nts toks) - enders - steps - nts - toks) - parsed? - deriv-trees* - nb-deriv-trees*)))))))))))))))))))))))) - (define parse->parsed? - (lambda (parse nt i j) - (let ((nts (vector-ref parse '0))) - (let ((enders (vector-ref parse '2))) - (let ((states (vector-ref parse '7))) - (let ((parsed? (vector-ref parse '8))) (parsed? nt i j nts enders states))))))) - (define parse->trees - (lambda (parse nt i j) - (let ((nts (vector-ref parse '0))) - (let ((enders (vector-ref parse '2))) - (let ((steps (vector-ref parse '4))) - (let ((names (vector-ref parse '5))) - (let ((toks (vector-ref parse '6))) - (let ((states (vector-ref parse '7))) - (let ((deriv-trees* (vector-ref parse '9))) - (deriv-trees* nt i j nts enders steps names toks states)))))))))) - (define parse->nb-trees - (lambda (parse nt i j) - (let ((nts (vector-ref parse '0))) - (let ((enders (vector-ref parse '2))) - (let ((steps (vector-ref parse '4))) - (let ((toks (vector-ref parse '6))) - (let ((states (vector-ref parse '7))) - (let ((nb-deriv-trees* (vector-ref parse '10))) - (nb-deriv-trees* nt i j nts enders steps toks states))))))))) - (define test - (lambda (k) - (let ((p (make-parser '((s (a) (s s))) - (lambda (l) - (map (lambda (x) (list x x)) l))))) - (let ((x (p (vector->list (make-vector k 'a))))) - (display (length (parse->trees x 's '0 k))) - (newline))))) - (test '12)) diff --git a/tests/earley/earley.sch b/tests/earley/earley.sch deleted file mode 100644 index b27dd88..0000000 --- a/tests/earley/earley.sch +++ /dev/null @@ -1,825 +0,0 @@ -(begin - (define make-parser - (lambda (grammar lexer) - (letrec ((non-terminals - (lambda (grammar) - (letrec ((add-nt (lambda (nt nts) (if (member nt nts) nts (cons nt nts))))) - ((letrec ((def-loop - (lambda (defs nts) - (if (pair? defs) - (let ((def (car defs))) - (let ((head (car def))) - ((letrec ((rule-loop - (lambda (rules nts) - (if (pair? rules) - (let ((rule (car rules))) - ((letrec ((loop - (lambda (l nts) - (if (pair? l) - (let ((nt (car l))) - (loop (cdr l) (add-nt nt nts))) - (rule-loop (cdr rules) nts))))) - loop) - rule - nts)) - (def-loop (cdr defs) nts))))) - rule-loop) - (cdr def) - (add-nt head nts)))) - (list->vector (reverse nts)))))) - def-loop) - grammar - '())))) - (ind - (lambda (nt nts) - ((letrec ((loop - (lambda (i) - (if (>= i '0) (if (equal? (vector-ref nts i) nt) i (loop (- i '1))) '#f)))) - loop) - (- (vector-length nts) '1)))) - (nb-configurations - (lambda (grammar) - ((letrec ((def-loop - (lambda (defs nb-confs) - (if (pair? defs) - (let ((def (car defs))) - ((letrec ((rule-loop - (lambda (rules nb-confs) - (if (pair? rules) - (let ((rule (car rules))) - ((letrec ((loop - (lambda (l nb-confs) - (if (pair? l) - (loop (cdr l) (+ nb-confs '1)) - (rule-loop (cdr rules) (+ nb-confs '1)))))) - loop) - rule - nb-confs)) - (def-loop (cdr defs) nb-confs))))) - rule-loop) - (cdr def) - nb-confs)) - nb-confs)))) - def-loop) - grammar - '0)))) - (let ((nts (non-terminals grammar))) - (let ((nb-nts (vector-length nts))) - (let ((nb-confs (+ (nb-configurations grammar) nb-nts))) - (let ((starters (make-vector nb-nts '()))) - (let ((enders (make-vector nb-nts '()))) - (let ((predictors (make-vector nb-nts '()))) - (let ((steps (make-vector nb-confs '#f))) - (let ((names (make-vector nb-confs '#f))) - (letrec ((setup-tables - (lambda (grammar nts starters enders predictors steps names) - (letrec ((add-conf - (lambda (conf nt nts class) - (let ((i (ind nt nts))) - (vector-set! class i (cons conf (vector-ref class i))))))) - (let ((nb-nts (vector-length nts))) - ((letrec ((nt-loop - (lambda (i) - (if (>= i '0) - (begin - (vector-set! steps i (- i nb-nts)) - (vector-set! names i (list (vector-ref nts i) '0)) - (vector-set! enders i (list i)) - (nt-loop (- i '1))) - '#f)))) - nt-loop) - (- nb-nts '1)) - ((letrec ((def-loop - (lambda (defs conf) - (if (pair? defs) - (let ((def (car defs))) - (let ((head (car def))) - ((letrec ((rule-loop - (lambda (rules conf rule-num) - (if (pair? rules) - (let ((rule (car rules))) - (vector-set! - names - conf - (list head rule-num)) - (add-conf conf head nts starters) - ((letrec ((loop - (lambda (l conf) - (if (pair? l) - (let ((nt (car l))) - (vector-set! - steps - conf - (ind nt nts)) - (add-conf - conf - nt - nts - predictors) - (loop - (cdr l) - (+ conf '1))) - (begin - (vector-set! - steps - conf - (- - (ind head nts) - nb-nts)) - (add-conf - conf - head - nts - enders) - (rule-loop - (cdr rules) - (+ conf '1) - (+ rule-num '1))))))) - loop) - rule - conf)) - (def-loop (cdr defs) conf))))) - rule-loop) - (cdr def) - conf - '1))) - '#f)))) - def-loop) - grammar - (vector-length nts))))))) - (setup-tables grammar nts starters enders predictors steps names) - (let ((parser-descr (vector lexer nts starters enders predictors steps names))) - (lambda (input) - (letrec ((ind - (lambda (nt nts) - ((letrec ((loop - (lambda (i) - (if (>= i '0) - (if (equal? (vector-ref nts i) nt) i (loop (- i '1))) - '#f)))) - loop) - (- (vector-length nts) '1)))) - (comp-tok - (lambda (tok nts) - ((letrec ((loop - (lambda (l1 l2) - (if (pair? l1) - (let ((i (ind (car l1) nts))) - (if i (loop (cdr l1) (cons i l2)) (loop (cdr l1) l2))) - (cons (car tok) (reverse l2)))))) - loop) - (cdr tok) - '()))) - (input->tokens - (lambda (input lexer nts) - (list->vector (map (lambda (tok) (comp-tok tok nts)) (lexer input))))) - (make-states - (lambda (nb-toks nb-confs) - (let ((states (make-vector (+ nb-toks '1) '#f))) - ((letrec ((loop - (lambda (i) - (if (>= i '0) - (let ((v (make-vector (+ nb-confs '1) '#f))) - (vector-set! v '0 '-1) - (vector-set! states i v) - (loop (- i '1))) - states)))) - loop) - nb-toks)))) - (conf-set-get (lambda (state conf) (vector-ref state (+ conf '1)))) - (conf-set-get* - (lambda (state state-num conf) - (let ((conf-set (conf-set-get state conf))) - (if conf-set - conf-set - (let ((conf-set (make-vector (+ state-num '6) '#f))) - (vector-set! conf-set '1 '-3) - (vector-set! conf-set '2 '-1) - (vector-set! conf-set '3 '-1) - (vector-set! conf-set '4 '-1) - (vector-set! state (+ conf '1) conf-set) - conf-set))))) - (conf-set-merge-new! - (lambda (conf-set) - (vector-set! - conf-set - (+ (vector-ref conf-set '1) '5) - (vector-ref conf-set '4)) - (vector-set! conf-set '1 (vector-ref conf-set '3)) - (vector-set! conf-set '3 '-1) - (vector-set! conf-set '4 '-1))) - (conf-set-head (lambda (conf-set) (vector-ref conf-set '2))) - (conf-set-next (lambda (conf-set i) (vector-ref conf-set (+ i '5)))) - (conf-set-member? - (lambda (state conf i) - (let ((conf-set (vector-ref state (+ conf '1)))) - (if conf-set (conf-set-next conf-set i) '#f)))) - (conf-set-adjoin - (lambda (state conf-set conf i) - (let ((tail (vector-ref conf-set '3))) - (vector-set! conf-set (+ i '5) '-1) - (vector-set! conf-set (+ tail '5) i) - (vector-set! conf-set '3 i) - (if (< tail '0) - (begin - (vector-set! conf-set '0 (vector-ref state '0)) - (vector-set! state '0 conf)) - '#f)))) - (conf-set-adjoin* - (lambda (states state-num l i) - (let ((state (vector-ref states state-num))) - ((letrec ((loop - (lambda (l1) - (if (pair? l1) - (let ((conf (car l1))) - (let ((conf-set (conf-set-get* state state-num conf))) - (if (not (conf-set-next conf-set i)) - (begin - (conf-set-adjoin state conf-set conf i) - (loop (cdr l1))) - (loop (cdr l1))))) - '#f)))) - loop) - l)))) - (conf-set-adjoin** - (lambda (states states* state-num conf i) - (let ((state (vector-ref states state-num))) - (if (conf-set-member? state conf i) - (let ((state* (vector-ref states* state-num))) - (let ((conf-set* (conf-set-get* state* state-num conf))) - (if (not (conf-set-next conf-set* i)) - (conf-set-adjoin state* conf-set* conf i) - '#f) - '#t)) - '#f)))) - (conf-set-union - (lambda (state conf-set conf other-set) - ((letrec ((loop - (lambda (i) - (if (>= i '0) - (if (not (conf-set-next conf-set i)) - (begin - (conf-set-adjoin state conf-set conf i) - (loop (conf-set-next other-set i))) - (loop (conf-set-next other-set i))) - '#f)))) - loop) - (conf-set-head other-set)))) - (forw - (lambda (states state-num starters enders predictors steps nts) - (letrec ((predict - (lambda (state state-num conf-set conf nt starters enders) - ((letrec ((loop1 - (lambda (l) - (if (pair? l) - (let ((starter (car l))) - (let ((starter-set - (conf-set-get* - state - state-num - starter))) - (if (not - (conf-set-next - starter-set - state-num)) - (begin - (conf-set-adjoin - state - starter-set - starter - state-num) - (loop1 (cdr l))) - (loop1 (cdr l))))) - '#f)))) - loop1) - (vector-ref starters nt)) - ((letrec ((loop2 - (lambda (l) - (if (pair? l) - (let ((ender (car l))) - (if (conf-set-member? state ender state-num) - (let ((next (+ conf '1))) - (let ((next-set - (conf-set-get* - state - state-num - next))) - (conf-set-union - state - next-set - next - conf-set) - (loop2 (cdr l)))) - (loop2 (cdr l)))) - '#f)))) - loop2) - (vector-ref enders nt)))) - (reduce - (lambda (states state state-num conf-set head preds) - ((letrec ((loop1 - (lambda (l) - (if (pair? l) - (let ((pred (car l))) - ((letrec ((loop2 - (lambda (i) - (if (>= i '0) - (let ((pred-set - (conf-set-get - (vector-ref states i) - pred))) - (if pred-set - (let ((next (+ pred '1))) - (let ((next-set - (conf-set-get* - state - state-num - next))) - (conf-set-union - state - next-set - next - pred-set))) - '#f) - (loop2 - (conf-set-next - conf-set - i))) - (loop1 (cdr l)))))) - loop2) - head)) - '#f)))) - loop1) - preds)))) - (let ((state (vector-ref states state-num)) - (nb-nts (vector-length nts))) - ((letrec ((loop - (lambda () - (let ((conf (vector-ref state '0))) - (if (>= conf '0) - (let ((step (vector-ref steps conf))) - (let ((conf-set (vector-ref state (+ conf '1)))) - (let ((head (vector-ref conf-set '4))) - (vector-set! - state - '0 - (vector-ref conf-set '0)) - (conf-set-merge-new! conf-set) - (if (>= step '0) - (predict - state - state-num - conf-set - conf - step - starters - enders) - (let ((preds - (vector-ref - predictors - (+ step nb-nts)))) - (reduce - states - state - state-num - conf-set - head - preds))) - (loop)))) - '#f))))) - loop)))))) - (forward - (lambda (starters enders predictors steps nts toks) - (let ((nb-toks (vector-length toks))) - (let ((nb-confs (vector-length steps))) - (let ((states (make-states nb-toks nb-confs))) - (let ((goal-starters (vector-ref starters '0))) - (conf-set-adjoin* states '0 goal-starters '0) - (forw states '0 starters enders predictors steps nts) - ((letrec ((loop - (lambda (i) - (if (< i nb-toks) - (let ((tok-nts (cdr (vector-ref toks i)))) - (conf-set-adjoin* states (+ i '1) tok-nts i) - (forw - states - (+ i '1) - starters - enders - predictors - steps - nts) - (loop (+ i '1))) - '#f)))) - loop) - '0) - states)))))) - (produce - (lambda (conf i j enders steps toks states states* nb-nts) - (let ((prev (- conf '1))) - (if (if (>= conf nb-nts) (>= (vector-ref steps prev) '0) '#f) - ((letrec ((loop1 - (lambda (l) - (if (pair? l) - (let ((ender (car l))) - (let ((ender-set - (conf-set-get (vector-ref states j) ender))) - (if ender-set - ((letrec ((loop2 - (lambda (k) - (if (>= k '0) - (begin - (if (>= k i) - (if (conf-set-adjoin** - states - states* - k - prev - i) - (conf-set-adjoin** - states - states* - j - ender - k) - '#f) - '#f) - (loop2 - (conf-set-next ender-set k))) - (loop1 (cdr l)))))) - loop2) - (conf-set-head ender-set)) - (loop1 (cdr l))))) - '#f)))) - loop1) - (vector-ref enders (vector-ref steps prev))) - '#f)))) - (back - (lambda (states states* state-num enders steps nb-nts toks) - (let ((state* (vector-ref states* state-num))) - ((letrec ((loop1 - (lambda () - (let ((conf (vector-ref state* '0))) - (if (>= conf '0) - (let ((conf-set (vector-ref state* (+ conf '1)))) - (let ((head (vector-ref conf-set '4))) - (vector-set! state* '0 (vector-ref conf-set '0)) - (conf-set-merge-new! conf-set) - ((letrec ((loop2 - (lambda (i) - (if (>= i '0) - (begin - (produce - conf - i - state-num - enders - steps - toks - states - states* - nb-nts) - (loop2 - (conf-set-next conf-set i))) - (loop1))))) - loop2) - head))) - '#f))))) - loop1))))) - (backward - (lambda (states enders steps nts toks) - (let ((nb-toks (vector-length toks))) - (let ((nb-confs (vector-length steps))) - (let ((nb-nts (vector-length nts))) - (let ((states* (make-states nb-toks nb-confs))) - (let ((goal-enders (vector-ref enders '0))) - ((letrec ((loop1 - (lambda (l) - (if (pair? l) - (let ((conf (car l))) - (conf-set-adjoin** - states - states* - nb-toks - conf - '0) - (loop1 (cdr l))) - '#f)))) - loop1) - goal-enders) - ((letrec ((loop2 - (lambda (i) - (if (>= i '0) - (begin - (back - states - states* - i - enders - steps - nb-nts - toks) - (loop2 (- i '1))) - '#f)))) - loop2) - nb-toks) - states*))))))) - (parsed? - (lambda (nt i j nts enders states) - (let ((nt* (ind nt nts))) - (if nt* - (let ((nb-nts (vector-length nts))) - ((letrec ((loop - (lambda (l) - (if (pair? l) - (let ((conf (car l))) - (if (conf-set-member? - (vector-ref states j) - conf - i) - '#t - (loop (cdr l)))) - '#f)))) - loop) - (vector-ref enders nt*))) - '#f)))) - (deriv-trees - (lambda (conf i j enders steps names toks states nb-nts) - (let ((name (vector-ref names conf))) - (if name - (if (< conf nb-nts) - (list (list name (car (vector-ref toks i)))) - (list (list name))) - (let ((prev (- conf '1))) - ((letrec ((loop1 - (lambda (l1 l2) - (if (pair? l1) - (let ((ender (car l1))) - (let ((ender-set - (conf-set-get - (vector-ref states j) - ender))) - (if ender-set - ((letrec ((loop2 - (lambda (k l2) - (if (>= k '0) - (if (if (>= k i) - (conf-set-member? - (vector-ref states k) - prev - i) - '#f) - (let ((prev-trees - (deriv-trees - prev - i - k - enders - steps - names - toks - states - nb-nts)) - (ender-trees - (deriv-trees - ender - k - j - enders - steps - names - toks - states - nb-nts))) - ((letrec ((loop3 - (lambda (l3 l2) - (if (pair? l3) - (let ((ender-tree - (list - (car - l3)))) - ((letrec ((loop4 - (lambda (l4 - l2) - (if (pair? - l4) - (loop4 - (cdr - l4) - (cons - (append - (car - l4) - ender-tree) - l2)) - (loop3 - (cdr - l3) - l2))))) - loop4) - prev-trees - l2)) - (loop2 - (conf-set-next - ender-set - k) - l2))))) - loop3) - ender-trees - l2)) - (loop2 - (conf-set-next ender-set k) - l2)) - (loop1 (cdr l1) l2))))) - loop2) - (conf-set-head ender-set) - l2) - (loop1 (cdr l1) l2)))) - l2)))) - loop1) - (vector-ref enders (vector-ref steps prev)) - '())))))) - (deriv-trees* - (lambda (nt i j nts enders steps names toks states) - (let ((nt* (ind nt nts))) - (if nt* - (let ((nb-nts (vector-length nts))) - ((letrec ((loop - (lambda (l trees) - (if (pair? l) - (let ((conf (car l))) - (if (conf-set-member? - (vector-ref states j) - conf - i) - (loop - (cdr l) - (append - (deriv-trees - conf - i - j - enders - steps - names - toks - states - nb-nts) - trees)) - (loop (cdr l) trees))) - trees)))) - loop) - (vector-ref enders nt*) - '())) - '#f)))) - (nb-deriv-trees - (lambda (conf i j enders steps toks states nb-nts) - (let ((prev (- conf '1))) - (if (let ((or-part (< conf nb-nts))) - (if or-part or-part (< (vector-ref steps prev) '0))) - '1 - ((letrec ((loop1 - (lambda (l n) - (if (pair? l) - (let ((ender (car l))) - (let ((ender-set - (conf-set-get (vector-ref states j) ender))) - (if ender-set - ((letrec ((loop2 - (lambda (k n) - (if (>= k '0) - (if (if (>= k i) - (conf-set-member? - (vector-ref states k) - prev - i) - '#f) - (let ((nb-prev-trees - (nb-deriv-trees - prev - i - k - enders - steps - toks - states - nb-nts)) - (nb-ender-trees - (nb-deriv-trees - ender - k - j - enders - steps - toks - states - nb-nts))) - (loop2 - (conf-set-next ender-set k) - (+ - n - (* - nb-prev-trees - nb-ender-trees)))) - (loop2 - (conf-set-next ender-set k) - n)) - (loop1 (cdr l) n))))) - loop2) - (conf-set-head ender-set) - n) - (loop1 (cdr l) n)))) - n)))) - loop1) - (vector-ref enders (vector-ref steps prev)) - '0))))) - (nb-deriv-trees* - (lambda (nt i j nts enders steps toks states) - (let ((nt* (ind nt nts))) - (if nt* - (let ((nb-nts (vector-length nts))) - ((letrec ((loop - (lambda (l nb-trees) - (if (pair? l) - (let ((conf (car l))) - (if (conf-set-member? - (vector-ref states j) - conf - i) - (loop - (cdr l) - (+ - (nb-deriv-trees - conf - i - j - enders - steps - toks - states - nb-nts) - nb-trees)) - (loop (cdr l) nb-trees))) - nb-trees)))) - loop) - (vector-ref enders nt*) - '0)) - '#f))))) - (let ((lexer (vector-ref parser-descr '0))) - (let ((nts (vector-ref parser-descr '1))) - (let ((starters (vector-ref parser-descr '2))) - (let ((enders (vector-ref parser-descr '3))) - (let ((predictors (vector-ref parser-descr '4))) - (let ((steps (vector-ref parser-descr '5))) - (let ((names (vector-ref parser-descr '6))) - (let ((toks (input->tokens input lexer nts))) - (vector - nts - starters - enders - predictors - steps - names - toks - (backward - (forward starters enders predictors steps nts toks) - enders - steps - nts - toks) - parsed? - deriv-trees* - nb-deriv-trees*)))))))))))))))))))))))) - (define parse->parsed? - (lambda (parse nt i j) - (let ((nts (vector-ref parse '0))) - (let ((enders (vector-ref parse '2))) - (let ((states (vector-ref parse '7))) - (let ((parsed? (vector-ref parse '8))) (parsed? nt i j nts enders states))))))) - (define parse->trees - (lambda (parse nt i j) - (let ((nts (vector-ref parse '0))) - (let ((enders (vector-ref parse '2))) - (let ((steps (vector-ref parse '4))) - (let ((names (vector-ref parse '5))) - (let ((toks (vector-ref parse '6))) - (let ((states (vector-ref parse '7))) - (let ((deriv-trees* (vector-ref parse '9))) - (deriv-trees* nt i j nts enders steps names toks states)))))))))) - (define parse->nb-trees - (lambda (parse nt i j) - (let ((nts (vector-ref parse '0))) - (let ((enders (vector-ref parse '2))) - (let ((steps (vector-ref parse '4))) - (let ((toks (vector-ref parse '6))) - (let ((states (vector-ref parse '7))) - (let ((nb-deriv-trees* (vector-ref parse '10))) - (nb-deriv-trees* nt i j nts enders steps toks states))))))))) - (define test - (lambda (k) - (let ((p (make-parser '((s (a) (s s))) - (lambda (l) - (map (lambda (x) (list x x)) l))))) - (let ((x (p (vector->list (make-vector k 'a))))) - (display (length (parse->trees x 's '0 k))) - (newline))))) - (test '12)) diff --git a/tests/earley/expected.txt b/tests/earley/expected.txt deleted file mode 100644 index 0a75d00..0000000 --- a/tests/earley/expected.txt +++ /dev/null @@ -1 +0,0 @@ -58786