From bbb53dbfab0cae2a92c2e85422c63df901d56945 Mon Sep 17 00:00:00 2001 From: "matthew.willis" Date: Mon, 21 Aug 2006 04:35:06 +0000 Subject: [PATCH] Added alien support, added core library --- contrib/lambda/core.factor | 65 ++++++++++++++++++++++++++++++++++++ contrib/lambda/lambda.TODO | 4 +-- contrib/lambda/lambda.factor | 3 +- contrib/lambda/load.factor | 1 + contrib/lambda/nodes.factor | 30 +++++++++++++---- contrib/lambda/parser.factor | 7 +++- 6 files changed, 99 insertions(+), 11 deletions(-) create mode 100644 contrib/lambda/core.factor diff --git a/contrib/lambda/core.factor b/contrib/lambda/core.factor new file mode 100644 index 0000000000..a3d723949b --- /dev/null +++ b/contrib/lambda/core.factor @@ -0,0 +1,65 @@ +USING: lazy-lists io strings sequences math namespaces kernel ; +IN: lambda + +: lambda-core ( -- expr-string-array ) + { + ":0 (one.(zero.zero))" + ":SUCC (num.(one.(zero.(one((num one) zero)))))" + } + + 0 lfrom 100 swap ltake list>array + [ + [ ":" , dup 1 + number>string , " (SUCC " , number>string , + ")" , ] { } make concat + ] map append + + 0 lfrom 26 swap ltake list>array + [ + [ ":" , dup 65 + ch>string , " " , number>string , ] { } make concat + ] map append + + { + ":LF 10" + ":FALSE (t.(f.f))" + ":TRUE (t.(f.t))" + ":ISZERO (num.((num (pred. FALSE)) TRUE))" + ":ADD (num.(other.((num SUCC) other)))" + ":MULT (num.(other.((num (ADD other)) 0)))" + ":PRED (n.(f.(x.(((n (g.(h.(h(g f))))) (u. x)) (u.u)))))" + ":SUBFROM (num.(other.((num PRED) other)))" + ":FACT (fact.(num.(((ISZERO num) 1) ((MULT num) (fact (PRED num))))))" + ":YCOMBINATOR (func.((y. (func (y y)))(y. (func (y y)))))" + ":FACTORIAL (YCOMBINATOR FACT)" + ":CONS (car.(cdr.(which.((which car) cdr))))" + ":CAR (cons.(cons TRUE))" + ":CDR (cons.(cons FALSE))" + ":PCONS (pcons.(num.(cons.(((ISZERO num) (PRINTSPECIAL LF)) ((PRINTCHAR (CAR cons)) ((pcons (PRED num)) (CDR cons)))))))" + ":PRINTCONS (YCOMBINATOR PCONS)" + ":NUMTOCHAR (num. ((ADD 48) num))" + ":ALPHATOCHAR (num. ((ADD 65) num))" + ":PRINTNUM (num.([PRINTCHAR] (ALIENNUM (NUMTOCHAR num))))" + ":PRINTCHAR (char.([PRINTCHAR] (ALIENNUM (ALPHATOCHAR char))))" + ":PRINTSPECIAL (special.([PRINTCHAR] (ALIENNUM special)))" + ":ALIEN0 alienbaseonenum" + ":ALIENNUM (num.((num [ALIENSUCC]) ALIEN0))" + ":HELLOCONS ((CONS H) ((CONS E) ((CONS Y) nil)))" + ":HELLO ((PRINTCONS 3) HELLOCONS)" + "(([HELLO] nil) ([INFO] nil)" + } append ; + +: print-return ( -- node ) + write "(nil.nil)" lambda-parse second ; + +: HELLO ( node -- node ) + drop "\nHello and Welcome to Lambda!\n" print-return ; + +: INFO ( node -- node ) + drop "Type HELLO and wait 10 seconds to see me flex my io muscles.\n" print-return ; + +: ALIENSUCC ( node -- node ) + variable-node-var "a" append ; + +: PRINTCHAR ( node -- node ) + #! takes a base one num and prints its char equivalent + variable-node-var length "alienbaseonenum" length - ch>string print-return ; + \ No newline at end of file diff --git a/contrib/lambda/lambda.TODO b/contrib/lambda/lambda.TODO index f5158e644d..aa12fab023 100644 --- a/contrib/lambda/lambda.TODO +++ b/contrib/lambda/lambda.TODO @@ -1,8 +1,6 @@ Lambda TODO ----------- -Change definition syntax from : to : Documentation Unit tests More graceful parse error handling -Factor out tree traversing into its own lib -Core library \ No newline at end of file +Factor out tree traversing into its own lib \ No newline at end of file diff --git a/contrib/lambda/lambda.factor b/contrib/lambda/lambda.factor index 27f98eb9cf..b1a997069c 100644 --- a/contrib/lambda/lambda.factor +++ b/contrib/lambda/lambda.factor @@ -29,7 +29,8 @@ IN: lambda : lambda-boot ( -- names ) #! load the core lambda library - H{ } clone ; + H{ } clone dup lambda-core + [ lambda-parse lambda-eval lambda-print drop ] each-with ; : (lambda) ( names -- names ) readln dup "." = [ drop ] [ diff --git a/contrib/lambda/load.factor b/contrib/lambda/load.factor index 70d6b7ff89..bd94a9dd49 100644 --- a/contrib/lambda/load.factor +++ b/contrib/lambda/load.factor @@ -1,6 +1,7 @@ PROVIDE: lambda { "nodes.factor" "parser.factor" + "core.factor" "lambda.factor" } { "test/lambda.factor" diff --git a/contrib/lambda/nodes.factor b/contrib/lambda/nodes.factor index de05fb627b..263a0d187e 100644 --- a/contrib/lambda/nodes.factor +++ b/contrib/lambda/nodes.factor @@ -1,7 +1,7 @@ #! A lambda expression manipulator, by Matthew Willis REQUIRES: lazy-lists ; USING: lazy-lists strings arrays hashtables -sequences namespaces words kernel ; +sequences namespaces words parser kernel ; IN: kernel : dip swap slip ; inline @@ -11,6 +11,7 @@ IN: lambda TUPLE: lambda-node expr original canonical ; TUPLE: apply-node func arg ; TUPLE: variable-node var ; +TUPLE: alien-node word ; DEFER: substitute C: lambda-node ( var expr implicit-empty-lambda-node -- lambda-node ) @@ -42,6 +43,8 @@ M: apply-node (traverse) ( data-array word apply-node -- node ) M: variable-node (traverse) ( data-array word variable-node -- node ) (pre) (post) ; +M: alien-node (traverse) ( data-array word alien-node -- node ) nip nip ; + : traverse ( node data-array {pre,post} -- node ) rot (traverse) ; @@ -103,6 +106,12 @@ M: variable-node (substitute) ( data-array variable-node -- node ) : eta-reduce ( lambda-node -- expr ) lambda-node-expr apply-node-func ; +DEFER: evaluate +: alien-reduce ( apply-node -- expr ) + #! execute the factor word in the alien-node + dup apply-node-arg evaluate + swap apply-node-func alien-node-word "lambda" lookup execute ; + GENERIC: evaluate M: lambda-node evaluate ( lambda-node -- node ) #! eta-reduction @@ -119,15 +128,21 @@ M: lambda-node evaluate ( lambda-node -- node ) M: apply-node evaluate ( apply-node -- node ) #! beta-reduction #! TODO: fix the weird recursion here - dup apply-node-func lambda-node? - [ beta-reduce evaluate ] + dup apply-node-func alien-node? + [ alien-reduce evaluate ] [ - dup apply-node-func evaluate swap [ set-apply-node-func ] keep - dup apply-node-func lambda-node? [ evaluate ] when + dup apply-node-func lambda-node? + [ beta-reduce evaluate ] + [ + dup apply-node-func evaluate swap [ set-apply-node-func ] keep + dup apply-node-func lambda-node? [ evaluate ] when + ] if ] if ; M: variable-node evaluate ( variable-node -- node ) ; +M: alien-node evaluate ( alien-node -- node ) ; + GENERIC: (replace-names) DEFER: replace-names M: lambda-node (replace-names) ( names-hash l-node -- node ) nip ; @@ -156,4 +171,7 @@ M: apply-node expr>string ( available-vars apply-node -- string ) [ "(" , , " " , , ")" , ] { } make concat ; M: variable-node expr>string ( available-vars variable-node -- string ) - nip variable-node-var dup string? [ lambda-node-canonical ] unless ; \ No newline at end of file + nip variable-node-var dup string? [ lambda-node-canonical ] unless ; + +M: alien-node expr>string ( available-vars alien-node -- string ) + nip [ "[" , alien-node-word , "]" , ] { } make concat ; \ No newline at end of file diff --git a/contrib/lambda/parser.factor b/contrib/lambda/parser.factor index de4cf29fe0..7343115e20 100644 --- a/contrib/lambda/parser.factor +++ b/contrib/lambda/parser.factor @@ -55,9 +55,14 @@ DEFER: "(" token sp &> sp <&> ")" token sp <& [ [ first ] keep second ] <@ ; +: + #! parses [], the alien invocation + #! an alien factor word must be all capital letters and numerals + "[" token sp &> "]" token sp <& [ ] <@ ; + : [ call ] [ call ] [ call ] <|> <|> - [ ] <@ <|> ; + [ ] <@ <|> <|> ; : ":" token &> sp <&> f succeed <&>