diff --git a/assemble-open-coded.rkt b/assemble-open-coded.rkt index 5c4e733..b158891 100644 --- a/assemble-open-coded.rkt +++ b/assemble-open-coded.rkt @@ -137,7 +137,7 @@ [(box) (format "(typeof(~a) === 'object' && (~a).length === 1)" operand-string operand-string)])]) - (format "((~a) ? (~a) : RUNTIME.raise(new Error('~a: expected ' + ~s + ' as argument ' + ~s + ' but received ' + ~a)))" + (format "((~a) ? (~a) : RUNTIME.raise(MACHINE, new Error('~a: expected ' + ~s + ' as argument ' + ~s + ' but received ' + ~a)))" test-string operand-string caller diff --git a/kernel-primitives.rkt b/kernel-primitives.rkt index c30cef0..b9604a5 100644 --- a/kernel-primitives.rkt +++ b/kernel-primitives.rkt @@ -12,7 +12,7 @@ ;; The following are primitives that the compiler knows about: -(define-type KernelPrimitiveName (U '+ +(define-type KernelPrimitiveName (U) #;(U '+ '- '* '/ diff --git a/runtime.js b/runtime.js index 4c50ea4..1479dac 100644 --- a/runtime.js +++ b/runtime.js @@ -215,33 +215,40 @@ var NULL = []; - var raise = function(e) { throw e; } - + var raise = function(MACHINE, e) { + if (typeof(window.console) !== 'undefined' && + typeof(console.log) === 'function') { + console.log(MACHINE); + console.log(e); + } + throw e; + }; // testArgument: (X -> boolean) X number string string -> boolean // Produces true if val is true, and otherwise raises an error. - var testArgument = function(expectedTypeName, + var testArgument = function(MACHINE, + expectedTypeName, predicate, val, - position, + index, callerName) { if (predicate(val)) { return true; } else { - raise(new Error(callerName + ": expected " + expectedTypeName - + " as argument #" + position - + " but received " + val + " instead")); + raise(MACHINE, new Error(callerName + ": expected " + expectedTypeName + + " as argument " + (index + 1) + + " but received " + val)); } }; var testArity = function(callerName, observed, minimum, maximum) { if (observed < minimum || observed > maximum) { - raise(new Error(callerName + ": expected at least " + minimum - + " arguments " - + " but received " + observer)); + raise(MACHINE, new Error(callerName + ": expected at least " + minimum + + " arguments " + + " but received " + observer)); } }; @@ -259,7 +266,7 @@ MACHINE.control.length - skip); } } - raise(new Error("captureControl: unable to find tag " + tag)); + raise(MACHINE, new Error("captureControl: unable to find tag " + tag)); }; @@ -278,7 +285,7 @@ return; } } - raise(new Error("restoreControl: unable to find tag " + tag)); + raise(MACHINE, new Error("restoreControl: unable to find tag " + tag)); }; @@ -390,9 +397,10 @@ Primitives['='] = function(MACHINE) { var firstArg = MACHINE.env[MACHINE.env.length-1]; - testArgument('number', isNumber, firstArg, 0, '='); - for (var i = 1; i < MACHINE.argcount; i++) { - testArgument('number', + testArgument(MACHINE, 'number', isNumber, firstArg, 0, '='); + for (var i = 0; i < MACHINE.argcount - 1; i++) { + testArgument(MACHINE, + 'number', isNumber, MACHINE.env[MACHINE.env.length - 1 - i], i, @@ -410,9 +418,11 @@ Primitives['<'] = function(MACHINE) { var firstArg = MACHINE.env[MACHINE.env.length-1]; - testArgument('number', isNumber, firstArg, 0, '<'); - for (var i = 1; i < MACHINE.argcount; i++) { - testArgument('number', + testArgument(MACHINE, + 'number', isNumber, firstArg, 0, '<'); + for (var i = 0; i < MACHINE.argcount - 1; i++) { + testArgument(MACHINE, + 'number', isNumber, MACHINE.env[MACHINE.env.length - 1 - i], i, @@ -429,9 +439,11 @@ Primitives['>'] = function(MACHINE) { var firstArg = MACHINE.env[MACHINE.env.length-1]; - testArgument('number', isNumber, firstArg, 0, '>'); - for (var i = 1; i < MACHINE.argcount; i++) { - testArgument('number', + testArgument(MACHINE, + 'number', isNumber, firstArg, 0, '>'); + for (var i = 0; i < MACHINE.argcount - 1; i++) { + testArgument(MACHINE, + 'number', isNumber, MACHINE.env[MACHINE.env.length - 1 - i], i, @@ -448,9 +460,11 @@ Primitives['<='] = function(MACHINE) { var firstArg = MACHINE.env[MACHINE.env.length-1]; - testArgument('number', isNumber, firstArg, 0, '<='); - for (var i = 1; i < MACHINE.argcount; i++) { - testArgument('number', + testArgument(MACHINE, + 'number', isNumber, firstArg, 0, '<='); + for (var i = 0; i < MACHINE.argcount - 1; i++) { + testArgument(MACHINE, + 'number', isNumber, MACHINE.env[MACHINE.env.length - 1 - i], i, @@ -468,9 +482,11 @@ Primitives['>='] = function(MACHINE) { var firstArg = MACHINE.env[MACHINE.env.length-1]; - testArgument('number', isNumber, firstArg, 0, '>='); - for (var i = 1; i < MACHINE.argcount; i++) { - testArgument('number', + testArgument(MACHINE, + 'number', isNumber, firstArg, 0, '>='); + for (var i = 0; i < MACHINE.argcount - 1; i++) { + testArgument(MACHINE, + 'number', isNumber, MACHINE.env[MACHINE.env.length - 1 - i], i, @@ -490,12 +506,12 @@ var result = 0; var i = 0; for (i=0; i < MACHINE.argcount; i++) { - testArgument( - 'number', - isNumber, - MACHINE.env[MACHINE.env.length - 1 - i], - i, - '+'); + testArgument(MACHINE, + 'number', + isNumber, + MACHINE.env[MACHINE.env.length - 1 - i], + i, + '+'); result += MACHINE.env[MACHINE.env.length - 1 - i]; }; return result; @@ -508,12 +524,12 @@ var result = 1; var i = 0; for (i=0; i < MACHINE.argcount; i++) { - testArgument( - 'number', - isNumber, - MACHINE.env[MACHINE.env.length - 1 - i], - i, - '*'); + testArgument(MACHINE, + 'number', + isNumber, + MACHINE.env[MACHINE.env.length - 1 - i], + i, + '*'); result *= MACHINE.env[MACHINE.env.length - 1 - i]; } return result; @@ -523,7 +539,8 @@ Primitives['-'] = function(MACHINE) { if (MACHINE.argcount === 1) { - testArgument('number', + testArgument(MACHINE, + 'number', isNumber, MACHINE.env[MACHINE.env.length-1], 0, @@ -532,7 +549,8 @@ } var result = MACHINE.env[MACHINE.env.length - 1]; for (var i = 1; i < MACHINE.argcount; i++) { - testArgument('number', + testArgument(MACHINE, + 'number', isNumber, MACHINE.env[MACHINE.env.length-1-i], i, @@ -545,13 +563,20 @@ Primitives['-'].displayName = '-'; Primitives['/'] = function(MACHINE) { - testArgument('number', + testArgument(MACHINE, + 'number', isNumber, MACHINE.env[MACHINE.env.length - 1], 0, '/'); var result = MACHINE.env[MACHINE.env.length - 1]; for (var i = 1; i < MACHINE.argcount; i++) { + testArgument(MACHINE, + 'number', + isNumber, + MACHINE.env[MACHINE.env.length-1-i], + i, + '/'); result /= MACHINE.env[MACHINE.env.length - 1 - i]; } return result; @@ -581,7 +606,8 @@ Primitives['list'].displayName = 'list'; Primitives['car'] = function(MACHINE) { - testArgument('pair', + testArgument(MACHINE, + 'pair', isPair, MACHINE.env[MACHINE.env.length - 1], 0, @@ -593,7 +619,8 @@ Primitives['car'].displayName = 'car'; Primitives['cdr'] = function(MACHINE) { - testArgument('pair', + testArgument(MACHINE, + 'pair', isPair, MACHINE.env[MACHINE.env.length - 1], 0, @@ -612,7 +639,8 @@ Primitives['pair?'].displayName = 'pair?'; Primitives['set-car!'] = function(MACHINE) { - testArgument('pair', + testArgument(MACHINE, + 'pair', isPair, MACHINE.env[MACHINE.env.length - 1], 0, @@ -625,7 +653,8 @@ Primitives['set-car!'].displayName = 'set-car!'; Primitives['set-cdr!'] = function(MACHINE) { - testArgument('pair', + testArgument(MACHINE, + 'pair', isPair, MACHINE.env[MACHINE.env.length - 1], 0, @@ -654,7 +683,8 @@ Primitives['null?'].displayName = 'null?'; Primitives['add1'] = function(MACHINE) { - testArgument('number', + testArgument(MACHINE, + 'number', isNumber, MACHINE.env[MACHINE.env.length - 1], 0, @@ -666,7 +696,8 @@ Primitives['add1'].displayName = 'add1'; Primitives['sub1'] = function(MACHINE) { - testArgument('number', + testArgument(MACHINE, + 'number', isNumber, MACHINE.env[MACHINE.env.length - 1], 0, @@ -696,7 +727,8 @@ Primitives['vector'].displayName = 'vector'; Primitives['vector->list'] = function(MACHINE) { - testArgument('vector', + testArgument(MACHINE, + 'vector', isVector, MACHINE.env[MACHINE.env.length - 1], 0, @@ -725,7 +757,8 @@ Primitives['list->vector'].displayName = 'list->vector'; Primitives['vector-ref'] = function(MACHINE) { - testArgument('vector', + testArgument(MACHINE, + 'vector', isVector, MACHINE.env[MACHINE.env.length - 1], 0, @@ -738,7 +771,8 @@ Primitives['vector-ref'].displayName = 'vector-ref'; Primitives['vector-set!'] = function(MACHINE) { - testArgument('vector', + testArgument(MACHINE, + 'vector', isVector, MACHINE.env[MACHINE.env.length - 1], 0, @@ -754,7 +788,8 @@ Primitives['vector-length'] = function(MACHINE) { - testArgument('vector', + testArgument(MACHINE, + 'vector', isVector, MACHINE.env[MACHINE.env.length - 1], 0, @@ -768,7 +803,8 @@ Primitives['make-vector'] = function(MACHINE) { var value = 0; - testArgument('natural', + testArgument(MACHINE, + 'natural', isNatural, MACHINE.env[MACHINE.env.length - 1], 0, @@ -898,10 +934,10 @@ var originalLst = lst; while (true) { if (! isList(lst)) { - raise(new Error("member: expected list" - + " as argument #2" - + " but received " + originalLst + " instead")); - }; + raise(MACHINE, new Error("member: expected list" + + " as argument #2" + + " but received " + originalLst + " instead")); + } if (lst === NULL) { return false; } @@ -931,17 +967,22 @@ 1); }; + + Primitives['reverse'] = function(MACHINE) { var rev = NULL; var lst = MACHINE.env[MACHINE.env.length-1]; while(lst !== NULL) { - testArgument('pair', isPair, lst, 0, 'reverse'); + testArgument(MACHINE, + 'pair', isPair, lst, 0, 'reverse'); rev = [lst[0], rev]; lst = lst[1]; } return rev; }; Primitives['reverse'].arity = 1; + Primitives['reverse'].displayName = 'reverse'; + @@ -988,6 +1029,7 @@ // Exports exports['Machine'] = Machine; + exports['Frame'] = Frame; exports['CallFrame'] = CallFrame; exports['PromptFrame'] = PromptFrame; exports['Closure'] = Closure; diff --git a/simulator-primitives.rkt b/simulator-primitives.rkt index 83d2c32..498e1b0 100644 --- a/simulator-primitives.rkt +++ b/simulator-primitives.rkt @@ -134,6 +134,36 @@ the-void-value)) + +(define my-member (lambda (x l) + (let loop ([l l]) + (cond + [(null? l) + #f] + [(MutablePair? l) + (cond + [(equal? x (MutablePair-h l)) + l] + [else + (loop (MutablePair-t l))])] + [else + (error 'member "not a list: ~s" l)])))) + +(define my-reverse (lambda (l) + (let loop ([l l] + [acc null]) + (cond + [(null? l) + acc] + [(MutablePair? l) + (loop (MutablePair-t l) + (make-MutablePair (MutablePair-h l) acc))] + [else + (error 'member "not a list: ~s" l)])))) + + + + (define current-continuation-marks (letrec ([f (case-lambda [(a-machine) (f a-machine default-continuation-prompt-tag-value)] @@ -200,7 +230,8 @@ (my-pair? pair?) (my-set-car! set-car!) (my-set-cdr! set-cdr!) - + (my-member member) + (my-reverse reverse) (my-box box) @@ -212,7 +243,8 @@ vector-ref (my-vector->list vector->list) (my-list->vector list->vector) - + vector-length + make-vector equal? diff --git a/test-browser-evaluate.rkt b/test-browser-evaluate.rkt index a6df336..a8b6cc1 100644 --- a/test-browser-evaluate.rkt +++ b/test-browser-evaluate.rkt @@ -333,6 +333,27 @@ EOF "false\n") +(test '(displayln (length (reverse '()))) + "0\n") + +(test '(displayln (car (reverse '("x")))) + "x\n") + +(test '(displayln (car (reverse '("x" "y")))) + "y\n") + +(test '(displayln (car (cdr (reverse '("x" "y"))))) + "x\n") + +(test '(displayln (car (reverse '("x" "y" "z")))) + "z\n") +(test '(displayln (car (cdr (reverse '("x" "y" "z"))))) + "y\n") +(test '(displayln (car (cdr (cdr (reverse '("x" "y" "z")))))) + "x\n") + + + #;(test (read (open-input-file "tests/conform/program0.sch")) (port->string (open-input-file "tests/conform/expected0.txt"))) \ No newline at end of file diff --git a/test-earley-browser.rkt b/test-earley-browser.rkt new file mode 100644 index 0000000..4d3dd73 --- /dev/null +++ b/test-earley-browser.rkt @@ -0,0 +1,52 @@ +#lang racket +(require "browser-evaluate.rkt" + "package.rkt" + racket/port + racket/runtime-path) + +(define-runtime-path runtime.js "runtime.js") + +(define evaluate (make-evaluate + (lambda (program op) + + (fprintf op "(function () {") + + ;; The runtime code + (call-with-input-file* runtime.js + (lambda (ip) + (copy-port ip op))) + + (newline op) + + (fprintf op "var innerInvoke = ") + (package-anonymous program op) + (fprintf op "();\n") + + (fprintf op #<string (open-input-file "tests/earley/expected.txt"))) \ No newline at end of file diff --git a/test-earley.rkt b/test-earley.rkt new file mode 100644 index 0000000..64cb267 --- /dev/null +++ b/test-earley.rkt @@ -0,0 +1,62 @@ +#lang racket + +(require "simulator.rkt" + "simulator-structs.rkt" + "compiler.rkt" + "parse.rkt" + "il-structs.rkt") + + +(define (run-compiler code) + (compile (parse code) 'val next-linkage)) + +;; run: machine -> (machine number) +;; Run the machine to completion. +(define (run m + #:debug? (debug? false) + #:stack-limit (stack-limit false) + #:control-limit (control-limit false)) + + #;(for-each displayln (vector->list (machine-text m))) + + (let loop ([steps 0]) + (when debug? + (when (can-step? m) + (printf "pc=~s, |env|=~s, |control|=~s, instruction=~s\n" + (machine-pc m) + (length (machine-env m)) + (length (machine-control m)) + (current-instruction m)))) + (when stack-limit + (when (> (machine-stack-size m) stack-limit) + (error 'run "Stack overflow"))) + + (when control-limit + (when (> (machine-control-size m) control-limit) + (error 'run "Control overflow"))) + + (cond + [(can-step? m) + (step! m) + (loop (add1 steps))] + [else + (values m steps)]))) + +;; Test out the compiler, using the simulator. +(define-syntax (test stx) + (syntax-case stx () + [(_ code exp options ...) + (with-syntax ([stx stx]) + (syntax/loc #'stx + (begin + (printf "Running... \n") + (let*-values([(a-machine num-steps) + (run (new-machine (run-compiler code) #t) options ...)] + [(actual) (machine-val a-machine)]) + (printf "ok. ~s steps.\n\n" num-steps)))))])) + + +(test (read (open-input-file "tests/earley/earley.sch")) + (port->string (open-input-file "tests/earley/expected.txt")) + ;;#:debug? #t + ) diff --git a/tests/earley/earley.sch b/tests/earley/earley.sch new file mode 100644 index 0000000..56f7f6c --- /dev/null +++ b/tests/earley/earley.sch @@ -0,0 +1,827 @@ +(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))))) + ;(displayln x) + ;(displayln (parse->trees x 's '0 k)) ;; dyoo : temporary + (display (length (parse->trees x 's '0 k))) + (newline))))) + (test '12)) diff --git a/tests/earley/expected.txt b/tests/earley/expected.txt new file mode 100644 index 0000000..0a75d00 --- /dev/null +++ b/tests/earley/expected.txt @@ -0,0 +1 @@ +58786