kanaka/mal
1
1
Fork 0
mirror of https://github.com/kanaka/mal.git synced 2024-09-11 13:55:55 +03:00
Code Issues Projects Releases Wiki Activity

factor: update code.

Browse Source 
* Works on soon-to-be-released 0.98 (triple quote strings removed)
* 50% more iterations per second on perf3.mal
* Removed 'src' directory, use 'factor' as the root
* Using 'mal' namespace for core, reader, printer, malenv, types
* Fixed issue with "empty" readline input (should be ignored and wasn't)
* Tried to simplify some of the code
This commit is contained in:
John Benediktsson 2015-10-28 16:16:43 -07:00
parent 953772ca00
commit 199b1ce7b2
47 changed files with 1235 additions and 1246 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -73,7 +73,7 @@ cs_STEP_TO_PROG = cs/$($(1)).exe
elixir_STEP_TO_PROG = elixir/lib/mix/tasks/$($(1)).ex
erlang_STEP_TO_PROG = erlang/$($(1))
es6_STEP_TO_PROG = es6/build/$($(1)).js
factor_STEP_TO_PROG = factor/src/$($(1))/$($(1)).factor
factor_STEP_TO_PROG = factor/$($(1))/$($(1)).factor
forth_STEP_TO_PROG = forth/$($(1)).fs
fsharp_STEP_TO_PROG = fsharp/$($(1)).exe
go_STEP_TO_PROG = go/$($(1))

2
README.md
View File

@ -239,7 +239,7 @@ The Factor implementation of mal has been tested with Factor 0.97
```
cd factor
FACTOR_ROOTS=src factor -run=stepX_YYY
FACTOR_ROOTS=. factor -run=stepX_YYY
```
### Forth

4
factor/Makefile
View File

@ -1,7 +1,7 @@
TESTS =
SOURCES_BASE = src/types/types.factor src/reader/reader.factor src/printer/printer.factor
SOURCES_LISP = src/malenv/malenv.factor src/core/core.factor src/stepA_mal/stepA_mal.factor
SOURCES_BASE = mal/types/types.factor mal/reader/reader.factor mal/printer/printer.factor
SOURCES_LISP = mal/env/env.factor mal/core/core.factor stepA_mal/stepA_mal.factor
SOURCES = $(SOURCES_BASE) $(SOURCES_LISP)
.PHONY: stats stats-lisp

74
factor/mal/core/core.factor Normal file
View File

@ -0,0 +1,74 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators
combinators.short-circuit fry grouping hash-sets hashtables io
io.encodings.utf8 io.files kernel lists mal.env mal.printer
mal.reader mal.types math namespaces readline sequences sets
system vectors ;
IN: mal.core
SYMBOL: mal-apply
: pr-str-stack ( exprs readably? glue -- str )
[ '[ _ (pr-str) ] map ] dip join ;
CONSTANT: empty-env T{ malenv f f H{ } }
CONSTANT: ns H{
{ "+" [ first2 + ] }
{ "-" [ first2 - ] }
{ "*" [ first2 * ] }
{ "/" [ first2 / ] }
{ "list" [ >array ] }
{ "list?" [ first array? ] }
{ "empty?" [ first empty? ] }
{ "count" [ first dup nil? [ drop 0 ] [ length ] if ] }
{ "=" [ first2 mal= ] }
{ "<" [ first2 < ] }
{ ">" [ first2 > ] }
{ ">=" [ first2 >= ] }
{ "<=" [ first2 <= ] }
{ "pr-str" [ t " " pr-str-stack ] }
{ "str" [ f "" pr-str-stack ] }
{ "prn" [ t " " pr-str-stack print flush nil ] }
{ "println" [ f " " pr-str-stack print flush nil ] }
{ "read-string" [ first read-str ] }
{ "slurp" [ first utf8 file-contents ] }
{ "cons" [ first2 swap prefix { } like ] }
{ "concat" [ concat { } like ] }
{ "nth" [ first2 swap nth ] }
{ "first" [ first [ nil ] [ first ] if-empty ] }
{ "rest" [ first [ { } ] [ rest { } like ] if-empty ] }
{ "throw" [ first throw ] }
{ "apply" [ unclip [ unclip-last append ] dip mal-apply get call( args fn -- maltype ) ] }
{ "map" [ first2 swap '[ 1array _ mal-apply get call( args fn -- maltype ) ] map { } like ] }
{ "nil?" [ first nil? ] }
{ "true?" [ first t = ] }
{ "false?" [ first f = ] }
{ "symbol" [ first <malsymbol> ] }
{ "symbol?" [ first malsymbol? ] }
{ "keyword" [ first <malkeyword> ] }
{ "keyword?" [ first malkeyword? ] }
{ "vector" [ >vector ] }
{ "vector?" [ first vector? ] }
{ "hash-map" [ 2 group parse-hashtable ] }
{ "map?" [ first hashtable? ] }
{ "assoc" [ unclip swap 2 group parse-hashtable assoc-union ] }
{ "dissoc" [ unclip swap >hash-set '[ drop _ in? not ] assoc-filter ] }
{ "get" [ first2 swap dup nil? [ nip ] [ ?at [ drop nil ] unless ] if ] }
{ "contains?" [ first2 swap dup nil? [ nip ] [ at* nip ] if ] }
{ "keys" [ first keys ] }
{ "vals" [ first values ] }
{ "sequential?" [ first { [ vector? ] [ array? ] } 1|| ] }
{ "readline" [ first readline ] }
{ "meta" [ first dup malfn? [ meta>> ] [ drop f ] if [ nil ] unless* ] }
{ "with-meta" [ first2 over malfn? [ [ clone ] dip >>meta ] when ] }
{ "atom" [ first <malatom> ] }
{ "atom?" [ first malatom? ] }
{ "deref" [ first val>> ] }
{ "reset!" [ first2 >>val val>> ] }
{ "swap!" [ { [ first ] [ second ] [ 2 tail ] [ first val>> ] } cleave
prefix swap mal-apply get call( args fn -- maltype ) >>val val>> ] }
{ "conj" [ unclip swap over array? [ reverse prepend ] [ append ] if ] }
{ "time-ms" [ drop nano-count 1,000,000 /i ] }
}

32
factor/mal/env/env.factor vendored Normal file
View File

@ -0,0 +1,32 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs formatting hashtables kernel math
sequences typed ;
IN: mal.env
TUPLE: malenv
{ outer read-only }
{ data hashtable read-only } ;
! set outer to f if top level env
C: <malenv> malenv
: new-env ( outer -- malenv ) H{ } clone malenv boa ;
TYPED: env-find ( key malenv: malenv -- value/f ? )
2dup [ name>> ] [ data>> ] bi* at* [
[ 2drop ] 2dip
] [
drop outer>> [ env-find ] [ drop f f ] if*
] if* ;
TYPED: env-set ( value key malenv: malenv -- )
[ name>> ] [ data>> ] bi* set-at ;
: env-get ( key assoc -- value )
dupd env-find [
nip
] [
drop name>> "'%s' not found" sprintf throw
] if ;

31
factor/mal/printer/printer.factor Normal file
View File

@ -0,0 +1,31 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs fry hashtables kernel lists
mal.types math math.parser sequences splitting strings summary
vectors ;
IN: mal.printer
GENERIC# (pr-str) 1 ( maltype readably? -- str )
M: object (pr-str) drop summary ;
M: malatom (pr-str) [ val>> ] dip (pr-str) "(atom " ")" surround ;
M: malfn (pr-str) 2drop "#<fn>" ;
M: malkeyword (pr-str) drop name>> ":" prepend ;
M: malsymbol (pr-str) drop name>> ;
M: number (pr-str) drop number>string ;
M: string (pr-str)
[
"\\" "\\\\" replace
"\"" "\\\"" replace
"\"" dup surround
] when ;
M: array (pr-str) '[ _ (pr-str) ] map " " join "(" ")" surround ;
M: vector (pr-str) '[ _ (pr-str) ] map " " join "[" "]" surround ;
M: hashtable (pr-str)
[ unzip ] dip '[ [ _ (pr-str) ] bi@ " " glue ] 2map
" " join "{" "}" surround ;
M: t (pr-str) 2drop "true" ;
M: f (pr-str) 2drop "false" ;
M: +nil+ (pr-str) 2drop "nil" ;
: pr-str ( maltype -- str )
t (pr-str) ;

65
factor/mal/reader/reader.factor Normal file
View File

@ -0,0 +1,65 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators grouping hashtables kernel lists
locals make mal.types math.parser regexp sequences splitting ;
IN: mal.reader
CONSTANT: token-regex R/ (~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)~^@]+)/
DEFER: read-form
: (read-atom) ( str -- maltype )
{
{ [ dup first CHAR: " = ] [ rest but-last "\\\"" "\"" replace ] }
{ [ dup first CHAR: : = ] [ rest <malkeyword> ] }
{ [ dup "false" = ] [ drop f ] }
{ [ dup "true" = ] [ drop t ] }
{ [ dup "nil" = ] [ drop nil ] }
[ <malsymbol> ]
} cond ;
: read-atom ( str -- maltype )
dup string>number [ nip ] [ (read-atom) ] if* ;
:: read-sequence ( seq closer exemplar -- seq maltype )
seq [
[
[ "expected " closer append throw ]
[ dup first closer = ] if-empty
] [
read-form ,
] until rest
] exemplar make ;
: read-list ( seq -- seq maltype )
")" { } read-sequence ;
: read-vector ( seq -- seq maltype )
"]" V{ } read-sequence ;
: read-hashmap ( seq -- seq maltype )
"}" V{ } read-sequence 2 group parse-hashtable ;
: consume-next-into-list ( seq symname -- seq maltype )
[ read-form ] dip <malsymbol> swap 2array ;
: read-form ( seq -- seq maltype )
unclip {
{ "(" [ read-list ] }
{ "[" [ read-vector ] }
{ "{" [ read-hashmap ] }
{ "'" [ "quote" consume-next-into-list ] }
{ "`" [ "quasiquote" consume-next-into-list ] }
{ "~" [ "unquote" consume-next-into-list ] }
{ "~@" [ "splice-unquote" consume-next-into-list ] }
{ "^" [ read-form [ read-form ] dip 2array "with-meta" <malsymbol> prefix ] }
{ "@" [ "deref" consume-next-into-list ] }
[ read-atom ]
} case ;
: tokenize ( str -- seq )
token-regex all-matching-subseqs
[ first CHAR: ; = not ] filter ;
: read-str ( str -- maltype )
tokenize [ " " throw ] [ read-form nip ] if-empty ;

34
factor/mal/types/types.factor Normal file
View File

@ -0,0 +1,34 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators.short-circuit kernel mal.env
sequences strings ;
IN: mal.types
TUPLE: malsymbol { name string read-only } ;
C: <malsymbol> malsymbol
: symeq? ( string other -- ? )
dup malsymbol? [ name>> = ] [ 2drop f ] if ;
TUPLE: malfn
{ env malenv read-only }
{ binds sequence read-only }
{ exprs read-only }
{ macro? boolean }
{ meta assoc } ;
: <malfn> ( env binds exprs -- fn )
f f malfn boa ;
TUPLE: malatom { val } ;
C: <malatom> malatom
TUPLE: malkeyword { name string read-only } ;
C: <malkeyword> malkeyword
: mal= ( obj1 obj2 -- ? )
2dup [ { [ ] [ sequence? ] [ string? not ] } 1&& ] bi@ and
[ sequence= ] [ = ] if ;

76
factor/src/core/core.factor
View File

@ -1,76 +0,0 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences arrays lists printer locals io strings malenv reader io.files io.encodings.utf8
fry types combinators.short-circuit vectors hashtables assocs hash-sets sets grouping namespaces accessors
combinators readline system ;
IN: core
SYMBOL: mal-apply
:: pr-str-stack ( exprs readably? glue -- str )
exprs [ readably? (pr-str) ] map glue join ;
: to-array ( seq -- array )
dup array? [ >array ] unless ;
CONSTANT: empty-env T{ malenv f H{ } }
CONSTANT: ns H{ { "+" [ first2 + ] }
{ "-" [ first2 - ] }
{ "*" [ first2 * ] }
{ "/" [ first2 / ] }
{ "list" [ >array ] }
{ "list?" [ first array? ] }
{ "empty?" [ first empty? ] }
{ "count" [ first dup nil? [ drop 0 ] [ length ] if ] }
{ "=" [ first2 2dup [ { [ ] [ sequence? ] [ string? not ] } 1&& ] bi@ and [ sequence= ] [ = ] if ] }
{ "<" [ first2 < ] }
{ ">" [ first2 > ] }
{ ">=" [ first2 >= ] }
{ "<=" [ first2 <= ] }
{ "pr-str" [ t " " pr-str-stack ] }
{ "str" [ f "" pr-str-stack ] }
{ "prn" [ t " " pr-str-stack print flush nil ] }
{ "println" [ f " " pr-str-stack print flush nil ] }
{ "read-string" [ first read-str ] }
{ "slurp" [ first utf8 file-contents ] }
{ "cons" [ first2 swap prefix to-array ] }
{ "concat" [ concat to-array ] }
{ "nth" [ first2 swap nth ] }
{ "first" [ first dup empty? [ drop nil ] [ first ] if ] }
{ "rest" [ first dup empty? [ drop { } ] [ rest to-array ] if ] }
{ "throw" [ first throw ] }
{ "apply" [ unclip [ unclip-last append ] dip mal-apply get call( args fn -- maltype ) ] }
{ "map" [ first2 swap '[ 1array _ mal-apply get call( args fn -- maltype ) ] map to-array ] }
{ "nil?" [ first nil? ] }
{ "true?" [ first t = ] }
{ "false?" [ first f = ] }
{ "symbol" [ first <malsymbol> ] }
{ "symbol?" [ first malsymbol? ] }
{ "keyword" [ first dup 1 head "\u00029e" = [ "\u00029e" prepend ] unless ] }
{ "keyword?" [ first { [ string? ] [ 1 head "\u00029e" = ] } 1&& ] }
{ "vector" [ >vector ] }
{ "vector?" [ first vector? ] }
{ "hash-map" [ 2 group parse-hashtable ] }
{ "map?" [ first hashtable? ] }
{ "assoc" [ unclip swap 2 group parse-hashtable assoc-union ] }
{ "dissoc" [ unclip swap >hash-set '[ drop _ in? not ] assoc-filter ] }
{ "get" [ first2 swap dup nil? [ nip ] [ ?at [ drop nil ] unless ] if ] }
{ "contains?" [ first2 swap dup nil? [ nip ] [ ?at nip ] if ] }
{ "keys" [ first keys ] }
{ "vals" [ first values ] }
{ "sequential?" [ first { [ vector? ] [ array? ] } 1|| ] }
{ "readline" [ first readline ] }
{ "meta" [ first dup fn? [ meta>> ] [ drop f ] if [ nil ] unless* ] }
{ "with-meta" [ first2 over fn? [ [ clone ] dip >>meta ] when ] }
{ "atom" [ first <malatom> ] }
{ "atom?" [ first malatom? ] }
{ "deref" [ first val>> ] }
{ "reset!" [ first2 >>val val>> ] }
{ "swap!" [ { [ first ] [ second ] [ 2 tail ] [ first val>> ] } cleave
prefix swap mal-apply get call( args fn -- maltype ) >>val val>> ] }
{ "conj" [ unclip swap over array? [ reverse prepend ] [ append ] if ] }
{ "time-ms" [ drop nano-count 1000000 / >integer ] }
}

42
factor/src/malenv/malenv.factor
View File

@ -1,42 +0,0 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel hashtables accessors assocs locals math sequences ;
IN: malenv
TUPLE: malenv
{ outer read-only }
{ data hashtable read-only } ;
! set outer to f if top level env
INSTANCE: malenv assoc
C: <malenv> malenv
: new-env ( outer -- malenv ) H{ } clone malenv boa ;
M:: malenv at* ( key assoc -- value/f ? )
key name>> assoc data>> at*
[ drop assoc outer>>
[ key ?of ]
[ f f ]
if*
]
unless* ;
M: malenv assoc-size ( assoc -- n )
[ data>> ] [ outer>> ] bi [ assoc-size ] bi@ + ;
M: malenv >alist ( assoc -- n )
[ data>> ] [ outer>> ] bi [ >alist ] bi@ append ;
M: malenv set-at ( value key assoc -- )
[ name>> ] [ data>> ] bi* set-at ;
M: malenv delete-at ( key assoc -- )
[ name>> ] [ data>> ] bi* delete-at ;
M: malenv clear-assoc ( assoc -- )
data>> clear-assoc ;
: get-or-throw ( key assoc -- value )
?at [ dup name>> "'" dup surround " not found" append throw ] unless ;

35
factor/src/printer/printer.factor
View File

@ -1,35 +0,0 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: types vectors math math.parser kernel accessors sequences combinators strings arrays lists
hashtables assocs combinators.short-circuit regexp quotations locals summary ;
IN: printer
:: pr-str-str ( str readably? -- str )
str dup { [ empty? not ] [ 1 head "\u00029e" = ] } 1&&
[ rest ":" prepend ]
[ readably? [ R/ \/ "\\\\" re-replace
R/ "/ """\\"""" re-replace
"\"" dup surround ] when ]
if ;
:: (pr-str) ( maltype readably? -- str )
maltype
{
{ [ dup malsymbol? ] [ name>> ] }
{ [ dup number? ] [ number>string ] }
{ [ dup string? ] [ readably? pr-str-str ] }
{ [ dup array? ] [ [ readably? (pr-str) ] map " " join "(" ")" surround ] }
{ [ dup vector? ] [ [ readably? (pr-str) ] map " " join "[" "]" surround ] }
{ [ dup hashtable? ] [ unzip
[ [ readably? (pr-str) ] bi@ " " glue ] 2map " " join
"{" "}" surround ] }
{ [ dup fn? ] [ drop "#<fn>" ] }
{ [ dup t = ] [ drop "true" ] }
{ [ dup f = ] [ drop "false" ] }
{ [ dup nil = ] [ drop "nil" ] }
{ [ dup malatom? ] [ val>> readably? (pr-str) "(atom " ")" surround ] }
[ summary ]
} cond ;
: pr-str ( maltype -- str )
t (pr-str) ;

65
factor/src/reader/reader.factor
View File

@ -1,65 +0,0 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: regexp strings kernel sequences math.parser types combinators locals prettyprint make lists math
grouping hashtables ;
IN: reader
CONSTANT: token-regex R/ (~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)~^@]+)/
DEFER: read-form
: read-atom ( str -- maltype )
{
{ [ dup string>number ] [ string>number ] }
{ [ dup 1 head "\"" = ] [ rest but-last R/ \\"/ "\"" re-replace ] }
{ [ dup 1 head ":" = ] [ rest "\u00029e" prepend ] }
{ [ dup "false" = ] [ drop f ] }
{ [ dup "true" = ] [ drop t ] }
{ [ dup "nil" = ] [ drop nil ] }
[ <malsymbol> ]
} cond ;
:: read-sequence ( seq closer exemplar -- seq maltype )
seq
[ [ [ "expected " closer append throw ] when-empty
dup first closer = ]
[ read-form , ]
until
rest
] exemplar make ;
: read-list ( seq -- seq maltype )
")" { } read-sequence ;
: read-vector ( seq -- seq maltype )
"]" V{ } read-sequence ;
: read-hashmap ( seq -- seq maltype )
"}" V{ } read-sequence
2 group parse-hashtable ;
: consume-next-into-list ( seq symname -- seq maltype )
[ rest read-form ] dip <malsymbol> swap { } 2sequence ;
: read-form ( seq -- seq maltype )
{
{ [ dup first "(" = ] [ rest read-list ] }
{ [ dup first "[" = ] [ rest read-vector ] }
{ [ dup first "{" = ] [ rest read-hashmap ] }
{ [ dup first "'" = ] [ "quote" consume-next-into-list ] }
{ [ dup first "`" = ] [ "quasiquote" consume-next-into-list ] }
{ [ dup first "~" = ] [ "unquote" consume-next-into-list ] }
{ [ dup first "~@" = ] [ "splice-unquote" consume-next-into-list ] }
{ [ dup first "^" = ] [ rest read-form [ read-form ] dip { } 2sequence "with-meta" <malsymbol> prefix ] }
{ [ dup first "@" = ] [ "deref" consume-next-into-list ] }
[ [ rest ] [ first read-atom ] bi ]
} cond ;
: tokenize ( str -- seq )
token-regex all-matching-slices
[ >string ] map
[ 1 head ";" = not ] filter ;
: read-str ( str -- maltype )
tokenize [ " " throw ] [ read-form nip ] if-empty ;

18
factor/src/step0_repl/step0_repl.factor
View File

@ -1,18 +0,0 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: io readline kernel system ;
IN: step0_repl
: READ ( x -- x ) ;
: EVAL ( x -- x ) ;
: PRINT ( x -- x ) ;
: rep ( x -- x ) READ EVAL PRINT ;
: main-loop ( -- )
[ 1 ]
[ "user> " readline
[ 0 exit ] unless*
rep print flush ]
while ;
MAIN: main-loop

18
factor/src/step1_read_print/step1_read_print.factor
View File

@ -1,18 +0,0 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: io readline kernel system reader printer continuations ;
IN: step1_read_print
: READ ( str -- maltype ) read-str ;
: EVAL ( maltype -- maltype ) ;
: PRINT ( maltype -- str ) pr-str ;
: rep ( x -- x ) [ READ EVAL PRINT ] [ nip ] recover ;
: main-loop ( -- )
[ 1 ]
[ "user> " readline
[ 0 exit ] unless*
rep print flush ]
while ;
MAIN: main-loop

50
factor/src/step2_eval/step2_eval.factor
View File

@ -1,50 +0,0 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: io readline kernel system reader printer continuations types arrays locals assocs sequences
combinators accessors fry quotations math ;
IN: step2_eval
CONSTANT: repl-env H{ { "+" [ + ] }
{ "-" [ - ] }
{ "*" [ * ] }
{ "/" [ / ] } }
DEFER: EVAL
: eval-symbol ( sym env -- ast )
[ name>> ] dip
?at [ dup "no variable " prepend throw ] unless ;
: eval-list ( list env -- ast )
'[ _ EVAL ] map ;
: eval-assoc ( assoc env -- ast )
'[ [ _ EVAL ] bi@ ] assoc-map ;
: eval-ast ( ast env -- ast )
{
{ [ over malsymbol? ] [ eval-symbol ] }
{ [ over sequence? ] [ eval-list ] }
{ [ over assoc? ] [ eval-assoc ] }
[ drop ]
} cond ;
: READ ( str -- maltype ) read-str ;
: EVAL ( maltype env -- maltype )
eval-ast
dup array?
[ unclip
dup quotation? [ "not a fn" throw ] unless
with-datastack first ]
when ;
: PRINT ( maltype -- str ) pr-str ;
: rep ( x -- x ) [ READ repl-env EVAL PRINT ] [ nip ] recover ;
: main-loop ( -- )
[ 1 ]
[ "user> " readline
[ 0 exit ] unless*
rep print flush ]
while ;
MAIN: main-loop

54
factor/src/step3_env/step3_env.factor
View File

@ -1,54 +0,0 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: io readline kernel system reader printer continuations types arrays locals assocs sequences
combinators accessors fry quotations math malenv namespaces grouping hashtables ;
IN: step3_env
CONSTANT: repl-bindings H{ { "+" [ + ] }
{ "-" [ - ] }
{ "*" [ * ] }
{ "/" [ / ] } }
SYMBOL: repl-env
DEFER: EVAL
: eval-ast ( ast env -- ast )
{
{ [ over malsymbol? ] [ get-or-throw ] }
{ [ over sequence? ] [ '[ _ EVAL ] map ] }
{ [ over assoc? ] [ '[ [ _ EVAL ] bi@ ] assoc-map ] }
[ drop ]
} cond ;
:: eval-set! ( key value env -- maltype )
value env EVAL [ key env set-at ] keep ;
:: eval-let* ( bindings body env -- maltype )
body bindings 2 group env new-env
[| env pair | pair first2 env EVAL swap env ?set-at ]
reduce EVAL ;
: READ ( str -- maltype ) read-str ;
:: EVAL ( maltype env -- maltype )
maltype dup array?
[ unclip
{
{ [ dup name>> "def!" = ] [ drop first2 env eval-set! ] }
{ [ dup name>> "let*" = ] [ drop first2 env eval-let* ] }
{ [ env eval-ast dup quotation? ] [ [ env eval-ast ] dip with-datastack first ] }
[ drop "not a fn" throw ]
} cond ]
[ env eval-ast ]
if ;
: PRINT ( maltype -- str ) pr-str ;
: rep ( x -- x ) [ READ repl-env get EVAL PRINT ] [ nip ] recover ;
: main-loop ( -- )
f repl-bindings <malenv> repl-env set
[ 1 ]
[ "user> " readline
[ 0 exit ] unless*
rep print flush ]
while ;
MAIN: main-loop

93
factor/src/step4_if_fn_do/step4_if_fn_do.factor
View File

@ -1,93 +0,0 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: io readline kernel system reader printer continuations arrays locals assocs sequences
combinators accessors fry quotations math malenv namespaces grouping hashtables lists
types splitting core ;
IN: step4_if_fn_do
SYMBOL: repl-env
DEFER: EVAL
: eval-ast ( ast env -- ast )
{
{ [ over malsymbol? ] [ get-or-throw ] }
{ [ over sequence? ] [ '[ _ EVAL ] map ] }
{ [ over assoc? ] [ '[ [ _ EVAL ] bi@ ] assoc-map ] }
[ drop ]
} cond ;
:: eval-set! ( key value env -- maltype )
value env EVAL [ key env set-at ] keep ;
:: eval-let* ( bindings body env -- maltype )
body bindings 2 group env new-env
[| env pair | pair first2 env EVAL swap env ?set-at ]
reduce EVAL ;
:: eval-if ( params env -- maltype )
{
{ [ params first env EVAL { f +nil+ } index not ] ! condition is true
[ params second env EVAL ] }
{ [ params length 2 > ] [ params third env EVAL ] }
[ nil ]
} cond ;
:: eval-fn* ( params env -- maltype )
env params first [ name>> ] map params second <fn> ;
: args-split ( bindlist -- bindlist restbinding/f )
[ "&" ] split dup length 1 >
[ first2 first ]
[ first f ]
if ;
:: make-bindings ( args bindlist restbinding/f -- bindingshash )
bindlist
args bindlist length cut-slice
[ zip ] dip
restbinding/f
[ swap >array 2array suffix ]
[ drop ]
if*
>hashtable ;
: apply ( args fn -- maltype )
{
{ [ dup fn? ]
[ [ exprs>> nip ] [ env>> nip ] [ binds>> args-split make-bindings ] 2tri <malenv>
EVAL ] }
{ [ dup callable? ] [ call( x -- y ) ] }
[ drop "not a fn" throw ]
} cond ;
: READ ( str -- maltype ) read-str ;
:: EVAL ( maltype env -- maltype )
maltype dup array?
[ unclip
{
{ [ "def!" over symeq? ] [ drop first2 env eval-set! ] }
{ [ "let*" over symeq? ] [ drop first2 env eval-let* ] }
{ [ "do" over symeq? ] [ drop env eval-ast last ] }
{ [ "if" over symeq? ] [ drop env eval-if ] }
{ [ "fn*" over symeq? ] [ drop env eval-fn* ] }
[ prefix [ env EVAL ] map unclip apply ]
} cond ]
[ env eval-ast ]
if ;
: PRINT ( maltype -- str ) pr-str ;
: rep ( x -- x ) [ READ repl-env get EVAL PRINT ] [ nip ] recover ;
: main-loop ( -- )
[ 1 ]
[ "user> " readline
[ 0 exit ] unless*
rep print flush ]
while ;
f ns <malenv> repl-env set-global
"(def! not (fn* (a) (if a false true)))" rep drop
MAIN: main-loop

100
factor/src/step5_tco/step5_tco.factor
View File

@ -1,100 +0,0 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: io readline kernel system reader printer continuations arrays locals assocs sequences
combinators accessors fry quotations math malenv namespaces grouping hashtables lists
types splitting core ;
IN: step5_tco
SYMBOL: repl-env
DEFER: EVAL
: eval-ast ( ast env -- ast )
{
{ [ over malsymbol? ] [ get-or-throw ] }
{ [ over sequence? ] [ '[ _ EVAL ] map ] }
{ [ over assoc? ] [ '[ [ _ EVAL ] bi@ ] assoc-map ] }
[ drop ]
} cond ;
:: eval-set! ( key value env -- maltype )
value env EVAL [ key env set-at ] keep ;
:: eval-let* ( bindings body env -- maltype env )
body bindings 2 group env new-env
[| env pair | pair first2 env EVAL swap env ?set-at ]
reduce ;
:: eval-do ( exprs env -- lastform env )
exprs empty?
[ { } f ]
[ exprs unclip-last env swap [ eval-ast ] dip nip env ]
if ;
:: eval-if ( params env -- maltype env/f )
{
{ [ params first env EVAL { f +nil+ } index not ] ! condition is true
[ params second env ] }
{ [ params length 2 > ] [ params third env ] }
[ nil f ]
} cond ;
:: eval-fn* ( params env -- maltype )
env params first [ name>> ] map params second <fn> ;
: args-split ( bindlist -- bindlist restbinding/f )
[ "&" ] split dup length 1 >
[ first2 first ]
[ first f ]
if ;
:: make-bindings ( args bindlist restbinding/f -- bindingshash )
bindlist
args bindlist length cut-slice
[ zip ] dip
restbinding/f
[ swap >array 2array suffix ]
[ drop ]
if*
>hashtable ;
: apply ( args fn -- maltype newenv/f )
{
{ [ dup fn? ]
[ [ exprs>> nip ] [ env>> nip ] [ binds>> args-split make-bindings ] 2tri <malenv> ] }
{ [ dup callable? ] [ call( x -- y ) f ] }
[ drop "not a fn" throw ]
} cond ;
: READ ( str -- maltype ) read-str ;
: EVAL ( maltype env -- maltype )
[ dup ]
[ over array?
[ [ unclip ] dip swap ! rest env first
{
{ [ "def!" over symeq? ] [ drop [ first2 ] dip eval-set! f ] }
{ [ "let*" over symeq? ] [ drop [ first2 ] dip eval-let* ] }
{ [ "do" over symeq? ] [ drop eval-do ] }
{ [ "if" over symeq? ] [ drop eval-if ] }
{ [ "fn*" over symeq? ] [ drop eval-fn* f ] }
[ swap [ prefix ] dip '[ _ EVAL ] map unclip apply ]
} cond ]
[ eval-ast f ]
if ]
while drop ;
: PRINT ( maltype -- str ) pr-str ;
: rep ( x -- x ) [ READ repl-env get EVAL PRINT ] [ nip pr-str ] recover ;
: main-loop ( -- )
[ 1 ]
[ "user> " readline
[ 0 exit ] unless*
rep print flush ]
while ;
f ns <malenv> repl-env set-global
"(def! not (fn* (a) (if a false true)))" rep drop
MAIN: main-loop

105
factor/src/step6_file/step6_file.factor
View File

@ -1,105 +0,0 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: io readline kernel system reader printer continuations arrays locals assocs sequences
combinators accessors fry quotations math malenv namespaces grouping hashtables lists
types splitting core command-line ;
IN: step6_file
SYMBOL: repl-env
DEFER: EVAL
: eval-ast ( ast env -- ast )
{
{ [ over malsymbol? ] [ get-or-throw ] }
{ [ over sequence? ] [ '[ _ EVAL ] map ] }
{ [ over assoc? ] [ '[ [ _ EVAL ] bi@ ] assoc-map ] }
[ drop ]
} cond ;
:: eval-set! ( key value env -- maltype )
value env EVAL [ key env set-at ] keep ;
:: eval-let* ( bindings body env -- maltype env )
body bindings 2 group env new-env
[| env pair | pair first2 env EVAL swap env ?set-at ]
reduce ;
:: eval-do ( exprs env -- lastform env )
exprs empty?
[ { } f ]
[ exprs unclip-last env swap [ eval-ast ] dip nip env ]
if ;
:: eval-if ( params env -- maltype env/f )
{
{ [ params first env EVAL { f +nil+ } index not ] ! condition is true
[ params second env ] }
{ [ params length 2 > ] [ params third env ] }
[ nil f ]
} cond ;
:: eval-fn* ( params env -- maltype )
env params first [ name>> ] map params second <fn> ;
: args-split ( bindlist -- bindlist restbinding/f )
[ "&" ] split dup length 1 >
[ first2 first ]
[ first f ]
if ;
:: make-bindings ( args bindlist restbinding/f -- bindingshash )
bindlist
args bindlist length cut-slice
[ zip ] dip
restbinding/f
[ swap >array 2array suffix ]
[ drop ]
if*
>hashtable ;
: apply ( args fn -- maltype newenv/f )
{
{ [ dup fn? ]
[ [ exprs>> nip ] [ env>> nip ] [ binds>> args-split make-bindings ] 2tri <malenv> ] }
{ [ dup callable? ] [ call( x -- y ) f ] }
[ drop "not a fn" throw ]
} cond ;
: READ ( str -- maltype ) read-str ;
: EVAL ( maltype env -- maltype )
[ dup ]
[ over array?
[ [ unclip ] dip swap ! rest env first
{
{ [ "def!" over symeq? ] [ drop [ first2 ] dip eval-set! f ] }
{ [ "let*" over symeq? ] [ drop [ first2 ] dip eval-let* ] }
{ [ "do" over symeq? ] [ drop eval-do ] }
{ [ "if" over symeq? ] [ drop eval-if ] }
{ [ "fn*" over symeq? ] [ drop eval-fn* f ] }
[ swap [ prefix ] dip '[ _ EVAL ] map unclip apply ]
} cond ]
[ eval-ast f ]
if ]
while drop ;
: PRINT ( maltype -- str ) pr-str ;
: rep ( x -- x ) [ READ repl-env get EVAL PRINT ] [ nip pr-str ] recover ;
: main-loop ( -- )
[ 1 ]
[ "user> " readline
[ 0 exit ] unless*
rep print flush ]
while ;
f ns <malenv> repl-env set-global
[ first repl-env get EVAL ] "eval" repl-env get data>> set-at
command-line get "*ARGV*" repl-env get data>> set-at
"(def! not (fn* (a) (if a false true)))" rep drop
"(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep drop
MAIN: main-loop

119
factor/src/step7_quote/step7_quote.factor
View File

@ -1,119 +0,0 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: io readline kernel system reader printer continuations arrays locals assocs sequences
combinators accessors fry quotations math malenv namespaces grouping hashtables lists
types splitting core command-line combinators.short-circuit prettyprint ;
IN: step7_quote
SYMBOL: repl-env
DEFER: EVAL
: eval-ast ( ast env -- ast )
{
{ [ over malsymbol? ] [ get-or-throw ] }
{ [ over sequence? ] [ '[ _ EVAL ] map ] }
{ [ over assoc? ] [ '[ [ _ EVAL ] bi@ ] assoc-map ] }
[ drop ]
} cond ;
:: eval-set! ( key value env -- maltype )
value env EVAL [ key env set-at ] keep ;
:: eval-let* ( bindings body env -- maltype env )
body bindings 2 group env new-env
[| env pair | pair first2 env EVAL swap env ?set-at ]
reduce ;
:: eval-do ( exprs env -- lastform env )
exprs empty?
[ { } f ]
[ exprs unclip-last env swap [ eval-ast ] dip nip env ]
if ;
:: eval-if ( params env -- maltype env/f )
{
{ [ params first env EVAL { f +nil+ } index not ] ! condition is true
[ params second env ] }
{ [ params length 2 > ] [ params third env ] }
[ nil f ]
} cond ;
:: eval-fn* ( params env -- maltype )
env params first [ name>> ] map params second <fn> ;
: args-split ( bindlist -- bindlist restbinding/f )
[ "&" ] split dup length 1 >
[ first2 first ]
[ first f ]
if ;
:: make-bindings ( args bindlist restbinding/f -- bindingshash )
bindlist
args bindlist length cut-slice
[ zip ] dip
restbinding/f
[ swap >array 2array suffix ]
[ drop ]
if*
>hashtable ;
: apply ( args fn -- maltype newenv/f )
{
{ [ dup fn? ]
[ [ exprs>> nip ] [ env>> nip ] [ binds>> args-split make-bindings ] 2tri <malenv> ] }
{ [ dup callable? ] [ call( x -- y ) f ] }
[ drop "not a fn" throw ]
} cond ;
: is-pair? ( maltype -- bool )
{ [ sequence? ] [ empty? not ] } 1&& ;
: quasiquote ( maltype -- maltype )
{
{ [ dup is-pair? not ] [ [ "quote" <malsymbol> ] dip 2array ] }
{ [ "unquote" over first symeq? ] [ second ] }
{ [ dup first { [ is-pair? ] [ first "splice-unquote" swap symeq? ] } 1&& ]
[ [ "concat" <malsymbol> ] dip unclip second swap quasiquote 3array ] }
[ "cons" <malsymbol> swap unclip quasiquote swap quasiquote 3array ]
} cond ;
: READ ( str -- maltype ) read-str ;
: EVAL ( maltype env -- maltype )
[ dup ]
[ over array?
[ [ unclip ] dip swap ! rest env first
{
{ [ "def!" over symeq? ] [ drop [ first2 ] dip eval-set! f ] }
{ [ "let*" over symeq? ] [ drop [ first2 ] dip eval-let* ] }
{ [ "do" over symeq? ] [ drop eval-do ] }
{ [ "if" over symeq? ] [ drop eval-if ] }
{ [ "fn*" over symeq? ] [ drop eval-fn* f ] }
{ [ "quote" over symeq? ] [ 2drop first f ] }
{ [ "quasiquote" over symeq? ] [ drop [ first quasiquote ] dip ] }
[ swap [ prefix ] dip '[ _ EVAL ] map unclip apply ]
} cond ]
[ eval-ast f ]
if ]
while drop ;
: PRINT ( maltype -- str ) pr-str ;
: rep ( x -- x ) [ READ repl-env get EVAL PRINT ] [ nip pr-str ] recover ;
: main-loop ( -- )
[ 1 ]
[ "user> " readline
[ 0 exit ] unless*
rep print flush ]
while ;
f ns <malenv> repl-env set-global
[ first repl-env get EVAL ] "eval" repl-env get data>> set-at
command-line get "*ARGV*" repl-env get data>> set-at
"(def! not (fn* (a) (if a false true)))" rep drop
"(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep drop
MAIN: main-loop

141
factor/src/step8_macros/step8_macros.factor
View File

@ -1,141 +0,0 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: io readline kernel system reader printer continuations arrays locals assocs sequences
combinators accessors fry quotations math malenv namespaces grouping hashtables lists
types splitting core command-line combinators.short-circuit ;
IN: step8_macros
SYMBOL: repl-env
DEFER: EVAL
: eval-ast ( ast env -- ast )
{
{ [ over malsymbol? ] [ get-or-throw ] }
{ [ over sequence? ] [ '[ _ EVAL ] map ] }
{ [ over assoc? ] [ '[ [ _ EVAL ] bi@ ] assoc-map ] }
[ drop ]
} cond ;
:: eval-def! ( key value env -- maltype )
value env EVAL [ key env set-at ] keep ;
:: eval-defmacro! ( key value env -- maltype )
value env EVAL t >>is-macro [ key env set-at ] keep ;
:: eval-let* ( bindings body env -- maltype env )
body bindings 2 group env new-env
[| env pair | pair first2 env EVAL swap env ?set-at ]
reduce ;
:: eval-do ( exprs env -- lastform env )
exprs empty?
[ { } f ]
[ exprs unclip-last env swap [ eval-ast ] dip nip env ]
if ;
:: eval-if ( params env -- maltype env/f )
{
{ [ params first env EVAL { f +nil+ } index not ] ! condition is true
[ params second env ] }
{ [ params length 2 > ] [ params third env ] }
[ nil f ]
} cond ;
:: eval-fn* ( params env -- maltype )
env params first [ name>> ] map params second <fn> ;
: args-split ( bindlist -- bindlist restbinding/f )
[ "&" ] split dup length 1 >
[ first2 first ]
[ first f ]
if ;
:: make-bindings ( args bindlist restbinding/f -- bindingshash )
bindlist
args bindlist length cut-slice
[ zip ] dip
restbinding/f
[ swap >array 2array suffix ]
[ drop ]
if*
>hashtable ;
: apply ( args fn -- maltype newenv/f )
{
{ [ dup fn? ]
[ [ exprs>> nip ] [ env>> nip ] [ binds>> args-split make-bindings ] 2tri <malenv> ] }
{ [ dup callable? ] [ call( x -- y ) f ] }
[ drop "not a fn" throw ]
} cond ;
: is-pair? ( maltype -- bool )
{ [ sequence? ] [ empty? not ] } 1&& ;
: quasiquote ( maltype -- maltype )
{
{ [ dup is-pair? not ] [ [ "quote" <malsymbol> ] dip 2array ] }
{ [ "unquote" over first symeq? ] [ second ] }
{ [ dup first { [ is-pair? ] [ first "splice-unquote" swap symeq? ] } 1&& ]
[ [ "concat" <malsymbol> ] dip unclip second swap quasiquote 3array ] }
[ "cons" <malsymbol> swap unclip swap [ quasiquote ] bi@ 3array ]
} cond ;
:: is-macro-call ( maltype env -- bool )
maltype { [ array? ]
[ first malsymbol? ]
[ first env at { [ fn? ] [ is-macro>> ] } 1&& ]
} 1&& ;
: macro-expand ( maltype env -- maltype )
[ 2dup is-macro-call ]
[ [ unclip ] dip get-or-throw apply [ EVAL ] keep ]
while drop ;
: READ ( str -- maltype ) read-str ;
: EVAL ( maltype env -- maltype )
[ dup ]
[ over array?
[ [ macro-expand ] keep
over array?
[ [ unclip ] dip swap ! rest env first
{
{ [ "def!" over symeq? ] [ drop [ first2 ] dip eval-def! f ] }
{ [ "defmacro!" over symeq? ] [ drop [ first2 ] dip eval-defmacro! f ] }
{ [ "let*" over symeq? ] [ drop [ first2 ] dip eval-let* ] }
{ [ "do" over symeq? ] [ drop eval-do ] }
{ [ "if" over symeq? ] [ drop eval-if ] }
{ [ "fn*" over symeq? ] [ drop eval-fn* f ] }
{ [ "quote" over symeq? ] [ 2drop first f ] }
{ [ "quasiquote" over symeq? ] [ drop [ first quasiquote ] dip ] }
{ [ "macroexpand" over symeq? ] [ drop [ first ] dip macro-expand f ] }
[ swap [ prefix ] dip '[ _ EVAL ] map unclip apply ]
} cond ]
[ drop f ]
if ]
[ eval-ast f ]
if ]
while drop ;
: PRINT ( maltype -- str ) pr-str ;
: rep ( x -- x ) [ READ repl-env get EVAL PRINT ] [ nip pr-str ] recover ;
: main-loop ( -- )
[ 1 ]
[ "user> " readline
[ 0 exit ] unless*
rep print flush ]
while ;
f ns <malenv> repl-env set-global
[ first repl-env get EVAL ] "eval" repl-env get data>> set-at
command-line get "*ARGV*" repl-env get data>> set-at
"(def! not (fn* (a) (if a false true)))" rep drop
"(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep drop
"(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" rep drop
"(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" rep drop
MAIN: main-loop

146
factor/src/step9_try/step9_try.factor
View File

@ -1,146 +0,0 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: io readline kernel system reader printer continuations arrays locals assocs sequences
combinators accessors fry quotations math malenv namespaces grouping hashtables lists
types core command-line combinators.short-circuit splitting ;
IN: step9_try
SYMBOL: repl-env
DEFER: EVAL
: eval-ast ( ast env -- ast )
{
{ [ over malsymbol? ] [ get-or-throw ] }
{ [ over sequence? ] [ '[ _ EVAL ] map ] }
{ [ over assoc? ] [ '[ [ _ EVAL ] bi@ ] assoc-map ] }
[ drop ]
} cond ;
:: eval-def! ( key value env -- maltype )
value env EVAL [ key env set-at ] keep ;
:: eval-defmacro! ( key value env -- maltype )
value env EVAL t >>is-macro [ key env set-at ] keep ;
:: eval-let* ( bindings body env -- maltype env )
body bindings 2 group env new-env
[| env pair | pair first2 env EVAL swap env ?set-at ]
reduce ;
:: eval-do ( exprs env -- lastform env )
exprs empty?
[ { } f ]
[ exprs unclip-last env swap [ eval-ast ] dip nip env ]
if ;
:: eval-if ( params env -- maltype env/f )
{
{ [ params first env EVAL { f +nil+ } index not ] ! condition is true
[ params second env ] }
{ [ params length 2 > ] [ params third env ] }
[ nil f ]
} cond ;
:: eval-fn* ( params env -- maltype )
env params first [ name>> ] map params second <fn> ;
:: eval-try* ( params env -- maltype )
[ params first env EVAL ]
[ params second second env new-env ?set-at params second third swap EVAL ]
recover ;
: args-split ( bindlist -- bindlist restbinding/f )
[ "&" ] split dup length 1 >
[ first2 first ]
[ first f ]
if ;
: make-bindings ( args bindlist restbinding/f -- bindingshash )
[ swap over length cut-slice [ zip ] dip ] dip
[ swap >array 2array suffix ]
[ drop ]
if*
>hashtable ;
: apply ( args fn -- maltype newenv/f )
{
{ [ dup fn? ]
[ [ exprs>> nip ] [ env>> nip ] [ binds>> args-split make-bindings ] 2tri <malenv> ] }
{ [ dup callable? ] [ call( x -- y ) f ] }
[ drop "not a fn" throw ]
} cond ;
: is-pair? ( maltype -- bool )
{ [ sequence? ] [ empty? not ] } 1&& ;
: quasiquote ( maltype -- maltype )
{
{ [ dup is-pair? not ] [ [ "quote" <malsymbol> ] dip 2array ] }
{ [ "unquote" over first symeq? ] [ second ] }
{ [ dup first { [ is-pair? ] [ first "splice-unquote" swap symeq? ] } 1&& ]
[ [ "concat" <malsymbol> ] dip unclip second swap quasiquote 3array ] }
[ "cons" <malsymbol> swap unclip swap [ quasiquote ] bi@ 3array ]
} cond ;
:: is-macro-call ( maltype env -- bool )
maltype { [ array? ]
[ first malsymbol? ]
[ first env at { [ fn? ] [ is-macro>> ] } 1&& ]
} 1&& ;
: macro-expand ( maltype env -- maltype )
[ 2dup is-macro-call ]
[ [ unclip ] dip get-or-throw apply [ EVAL ] keep ]
while drop ;
: READ ( str -- maltype ) read-str ;
: EVAL ( maltype env -- maltype )
[ dup ]
[ over array?
[ [ macro-expand ] keep
over array?
[ [ unclip ] dip swap ! rest env first
{
{ [ "def!" over symeq? ] [ drop [ first2 ] dip eval-def! f ] }
{ [ "defmacro!" over symeq? ] [ drop [ first2 ] dip eval-defmacro! f ] }
{ [ "let*" over symeq? ] [ drop [ first2 ] dip eval-let* ] }
{ [ "do" over symeq? ] [ drop eval-do ] }
{ [ "if" over symeq? ] [ drop eval-if ] }
{ [ "fn*" over symeq? ] [ drop eval-fn* f ] }
{ [ "quote" over symeq? ] [ 2drop first f ] }
{ [ "quasiquote" over symeq? ] [ drop [ first quasiquote ] dip ] }
{ [ "macroexpand" over symeq? ] [ drop [ first ] dip macro-expand f ] }
{ [ "try*" over symeq? ] [ drop eval-try* f ] }
[ swap [ prefix ] dip '[ _ EVAL ] map unclip apply ]
} cond ]
[ drop f ]
if ]
[ eval-ast f ]
if ]
while drop ;
[ apply [ EVAL ] when* ] mal-apply set-global
: PRINT ( maltype -- str ) pr-str ;
: rep ( x -- x ) [ READ repl-env get EVAL PRINT ] [ nip pr-str ] recover ;
: main-loop ( -- )
[ 1 ]
[ "user> " readline
[ 0 exit ] unless*
rep print flush ]
while ;
f ns <malenv> repl-env set-global
[ first repl-env get EVAL ] "eval" repl-env get data>> set-at
command-line get "*ARGV*" repl-env get data>> set-at
"(def! not (fn* (a) (if a false true)))" rep drop
"(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep drop
"(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" rep drop
"(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" rep drop
MAIN: main-loop

155
factor/src/stepA_mal/stepA_mal.factor
View File

@ -1,155 +0,0 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: io readline kernel system reader printer continuations arrays locals assocs sequences
combinators accessors fry quotations math malenv namespaces grouping hashtables lists
types core command-line combinators.short-circuit splitting strings prettyprint ;
IN: stepA_mal
SYMBOL: repl-env
DEFER: EVAL
: eval-ast ( ast env -- ast )
{
{ [ over malsymbol? ] [ get-or-throw ] }
{ [ over sequence? ] [ '[ _ EVAL ] map ] }
{ [ over assoc? ] [ '[ [ _ EVAL ] bi@ ] assoc-map ] }
[ drop ]
} cond ;
:: eval-def! ( key value env -- maltype )
value env EVAL [ key env set-at ] keep ;
:: eval-defmacro! ( key value env -- maltype )
value env EVAL t >>is-macro [ key env set-at ] keep ;
:: eval-let* ( bindings body env -- maltype env )
body bindings 2 group env new-env
[| env pair | pair first2 env EVAL swap env ?set-at ]
reduce ;
:: eval-do ( exprs env -- lastform env )
exprs empty?
[ { } f ]
[ exprs unclip-last env swap [ eval-ast ] dip nip env ]
if ;
:: eval-if ( params env -- maltype env/f )
{
{ [ params first env EVAL { f +nil+ } index not ] ! condition is true
[ params second env ] }
{ [ params length 2 > ] [ params third env ] }
[ nil f ]
} cond ;
:: eval-fn* ( params env -- maltype )
env params first [ name>> ] map params second <fn> ;
:: eval-try* ( params env -- maltype )
[ params first env EVAL ]
[ params second second env new-env ?set-at params second third swap EVAL ]
recover ;
: args-split ( bindlist -- bindlist restbinding/f )
[ "&" ] split dup length 1 >
[ first2 first ]
[ first f ]
if ;
: make-bindings ( args bindlist restbinding/f -- bindingshash )
[ swap over length cut-slice [ zip ] dip ] dip
[ swap >array 2array suffix ]
[ drop ]
if*
>hashtable ;
: apply ( args fn -- maltype newenv/f )
{
{ [ dup fn? ]
[ [ exprs>> nip ] [ env>> nip ] [ binds>> args-split make-bindings ] 2tri <malenv> ] }
{ [ dup callable? ] [ call( x -- y ) f ] }
[ . . "not a fn" throw ]
} cond ;
: is-pair? ( maltype -- bool )
{ [ sequence? ] [ string? not ] [ empty? not ] } 1&& ;
: quasiquote ( maltype -- maltype )
{
{ [ dup is-pair? not ] [ [ "quote" <malsymbol> ] dip 2array ] }
{ [ "unquote" over first symeq? ] [ second ] }
{ [ dup first { [ is-pair? ] [ first "splice-unquote" swap symeq? ] } 1&& ]
[ [ "concat" <malsymbol> ] dip unclip second swap quasiquote 3array ] }
[ "cons" <malsymbol> swap unclip swap [ quasiquote ] bi@ 3array ]
} cond ;
:: is-macro-call ( maltype env -- bool )
maltype { [ array? ]
[ first malsymbol? ]
[ first env at { [ fn? ] [ is-macro>> ] } 1&& ]
} 1&& ;
: macro-expand ( maltype env -- maltype )
[ 2dup is-macro-call ]
[ [ unclip ] dip get-or-throw apply [ EVAL ] keep ]
while drop ;
: READ ( str -- maltype ) read-str ;
: EVAL ( maltype env -- maltype )
[ dup ]
[ over array?
[ [ macro-expand ] keep
over array?
[ [ unclip ] dip swap ! rest env first
{
{ [ "def!" over symeq? ] [ drop [ first2 ] dip eval-def! f ] }
{ [ "defmacro!" over symeq? ] [ drop [ first2 ] dip eval-defmacro! f ] }
{ [ "let*" over symeq? ] [ drop [ first2 ] dip eval-let* ] }
{ [ "do" over symeq? ] [ drop eval-do ] }
{ [ "if" over symeq? ] [ drop eval-if ] }
{ [ "fn*" over symeq? ] [ drop eval-fn* f ] }
{ [ "quote" over symeq? ] [ 2drop first f ] }
{ [ "quasiquote" over symeq? ] [ drop [ first quasiquote ] dip ] }
{ [ "macroexpand" over symeq? ] [ drop [ first ] dip macro-expand f ] }
{ [ "try*" over symeq? ] [ drop eval-try* f ] }
[ swap [ prefix ] dip '[ _ EVAL ] map unclip apply ]
} cond ]
[ drop f ]
if ]
[ eval-ast f ]
if ]
while drop ;
[ apply [ EVAL ] when* ] mal-apply set-global
: PRINT ( maltype -- str ) pr-str ;
: rep ( x -- x ) [ READ repl-env get EVAL PRINT ] [ nip pr-str ] recover ;
: main-loop ( -- )
"(println (str \"Mal [\" *host-language* \"]\"))" rep drop
[ 1 ]
[ "user> " readline
[ 0 exit ] unless*
rep print flush ]
while ;
: main ( -- )
command-line get dup empty?
[ drop main-loop ]
[ first "(load-file \"" "\")" surround rep print flush ]
if ;
f ns <malenv> repl-env set-global
[ first repl-env get EVAL ] "eval" repl-env get data>> set-at
command-line get dup empty? [ rest ] unless "*ARGV*" repl-env get data>> set-at
"(def! *host-language* \"factor\")" rep drop
"(def! not (fn* (a) (if a false true)))" rep drop
"(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep drop
"(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" rep drop
"(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" rep drop
MAIN: main

25
factor/src/types/types.factor
View File

@ -1,25 +0,0 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: regexp strings kernel sequences math.parser accessors malenv assocs ;
IN: types
TUPLE: malsymbol { name string read-only } ;
C: <malsymbol> malsymbol
: symeq? ( string other -- ? )
dup malsymbol? [ name>> = ] [ 2drop f ] if ;
TUPLE: fn { env malenv read-only }
{ binds sequence read-only }
{ exprs read-only }
{ is-macro boolean }
{ meta assoc } ;
C: (<fn>) fn
: <fn> ( env binds exprs -- fn )
f f (<fn>) ;
TUPLE: malatom { val } ;
C: <malatom> malatom

0
factor/src/step0_repl/deploy.factor → factor/step0_repl/deploy.factor
View File

21
factor/step0_repl/step0_repl.factor Executable file
View File

@ -0,0 +1,21 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel readline sequences ;
IN: step0_repl
: READ ( x -- x ) ;
: EVAL ( x -- x ) ;
: PRINT ( x -- x ) ;
: REP ( x -- x ) READ EVAL PRINT ;
: REPL ( -- )
[
"user> " readline [
[ REP print flush ] unless-empty
] keep
] loop ;
MAIN: REPL

0
factor/src/step1_read_print/deploy.factor → factor/step1_read_print/deploy.factor
View File

23
factor/step1_read_print/step1_read_print.factor Executable file
View File

@ -0,0 +1,23 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations io kernel mal.printer mal.reader readline
sequences ;
IN: step1_read_print
: READ ( str -- maltype ) read-str ;
: EVAL ( maltype -- maltype ) ;
: PRINT ( maltype -- str ) pr-str ;
: REP ( str -- str )
[ READ EVAL ] [ nip ] recover PRINT ;
: REPL ( -- )
[
"user> " readline [
[ REP print flush ] unless-empty
] keep
] loop ;
MAIN: REPL

0
factor/src/step2_eval/deploy.factor → factor/step2_eval/deploy.factor
View File

55
factor/step2_eval/step2_eval.factor Executable file
View File

@ -0,0 +1,55 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators continuations fry io
kernel math mal.printer mal.reader mal.types quotations readline
sequences ;
IN: step2_eval
CONSTANT: repl-env H{
{ "+" [ + ] }
{ "-" [ - ] }
{ "*" [ * ] }
{ "/" [ / ] }
}
DEFER: EVAL
: eval-symbol ( sym env -- ast )
[ name>> ] dip ?at [ "no variable " prepend throw ] unless ;
: eval-list ( list env -- ast )
'[ _ EVAL ] map ;
: eval-assoc ( assoc env -- ast )
'[ [ _ EVAL ] bi@ ] assoc-map ;
: eval-ast ( ast env -- ast )
{
{ [ over malsymbol? ] [ eval-symbol ] }
{ [ over sequence? ] [ eval-list ] }
{ [ over assoc? ] [ eval-assoc ] }
[ drop ]
} cond ;
: READ ( str -- maltype ) read-str ;
: EVAL ( maltype env -- maltype )
eval-ast dup array? [
unclip
dup quotation? [ "not a fn" throw ] unless
with-datastack first
] when ;
: PRINT ( maltype -- str ) pr-str ;
: REP ( str -- str )
[ READ repl-env EVAL ] [ nip ] recover PRINT ;
: REPL ( -- )
[
"user> " readline [
[ REP print flush ] unless-empty
] keep
] loop ;
MAIN: REPL

0
factor/src/step3_env/deploy.factor → factor/step3_env/deploy.factor
View File

68
factor/step3_env/step3_env.factor Executable file
View File

@ -0,0 +1,68 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators continuations fry
grouping hashtables io kernel locals mal.env mal.printer
mal.reader mal.types math namespaces quotations readline
sequences ;
IN: step3_env
CONSTANT: repl-bindings H{
{ "+" [ + ] }
{ "-" [ - ] }
{ "*" [ * ] }
{ "/" [ / ] }
}
SYMBOL: repl-env
DEFER: EVAL
: eval-ast ( ast env -- ast )
{
{ [ over malsymbol? ] [ env-get ] }
{ [ over sequence? ] [ '[ _ EVAL ] map ] }
{ [ over assoc? ] [ '[ [ _ EVAL ] bi@ ] assoc-map ] }
[ drop ]
} cond ;
:: eval-def! ( key value env -- maltype )
value env EVAL [ key env env-set ] keep ;
: eval-let* ( bindings body env -- maltype )
[ swap 2 group ] [ new-env ] bi* [
dup '[ first2 _ EVAL swap _ env-set ] each
] keep EVAL ;
: READ ( str -- maltype ) read-str ;
:: EVAL ( maltype env -- maltype )
maltype dup array? [
unclip dup dup malsymbol? [ name>> ] when {
{ "def!" [ drop first2 env eval-def! ] }
{ "let*" [ drop first2 env eval-let* ] }
[
drop env eval-ast dup quotation? [
[ env eval-ast ] dip with-datastack first
] [
drop "not a fn" throw
] if
]
} case
] [
env eval-ast
] if ;
: PRINT ( maltype -- str ) pr-str ;
: REP ( str -- str )
[ READ repl-env get EVAL ] [ nip ] recover PRINT ;
: REPL ( -- )
f repl-bindings <malenv> repl-env set
[
"user> " readline [
[ REP print flush ] unless-empty
] keep
] loop ;
MAIN: REPL

0
factor/src/step4_if_fn_do/deploy.factor → factor/step4_if_fn_do/deploy.factor
View File

86
factor/step4_if_fn_do/step4_if_fn_do.factor Executable file
View File

@ -0,0 +1,86 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators continuations fry
grouping hashtables io kernel lists locals mal.core mal.env
mal.printer mal.reader mal.types math namespaces quotations
readline sequences splitting ;
IN: step4_if_fn_do
SYMBOL: repl-env
DEFER: EVAL
: eval-ast ( ast env -- ast )
{
{ [ over malsymbol? ] [ env-get ] }
{ [ over sequence? ] [ '[ _ EVAL ] map ] }
{ [ over assoc? ] [ '[ [ _ EVAL ] bi@ ] assoc-map ] }
[ drop ]
} cond ;
:: eval-def! ( key value env -- maltype )
value env EVAL [ key env env-set ] keep ;
: eval-let* ( bindings body env -- maltype )
[ swap 2 group ] [ new-env ] bi* [
dup '[ first2 _ EVAL swap _ env-set ] each
] keep EVAL ;
:: eval-if ( params env -- maltype )
params first env EVAL { f +nil+ } index not [
params second env EVAL
] [
params length 2 > [ params third env EVAL ] [ nil ] if
] if ;
:: eval-fn* ( params env -- maltype )
env params first [ name>> ] map params second <malfn> ;
: args-split ( bindlist -- bindlist restbinding/f )
{ "&" } split1 ?first ;
: make-bindings ( args bindlist restbinding/f -- bindingshash )
swapd [ over length cut [ zip ] dip ] dip
[ swap 2array suffix ] [ drop ] if* >hashtable ;
GENERIC: apply ( args fn -- maltype )
M: malfn apply
[ exprs>> nip ]
[ env>> nip ]
[ binds>> args-split make-bindings ] 2tri <malenv> EVAL ;
M: callable apply call( x -- y ) ;
: READ ( str -- maltype ) read-str ;
:: EVAL ( maltype env -- maltype )
maltype dup array? [
dup first dup malsymbol? [ name>> ] when {
{ "def!" [ rest first2 env eval-def! ] }
{ "let*" [ rest first2 env eval-let* ] }
{ "do" [ rest env eval-ast last ] }
{ "if" [ rest env eval-if ] }
{ "fn*" [ rest env eval-fn* ] }
[ drop [ env EVAL ] map unclip apply ]
} case
] [
env eval-ast
] if ;
: PRINT ( maltype -- str ) pr-str ;
: REP ( str -- str )
[ READ repl-env get EVAL ] [ nip ] recover PRINT ;
: REPL ( -- )
[
"user> " readline [
[ REP print flush ] unless-empty
] keep
] loop ;
f ns <malenv> repl-env set-global
"(def! not (fn* (a) (if a false true)))" REP drop
MAIN: REPL

0
factor/src/step5_tco/deploy.factor → factor/step5_tco/deploy.factor
View File

94
factor/step5_tco/step5_tco.factor Executable file
View File

@ -0,0 +1,94 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators continuations fry
grouping hashtables io kernel lists locals mal.core mal.env
mal.printer mal.reader mal.types math namespaces quotations
readline sequences splitting ;
IN: step5_tco
SYMBOL: repl-env
DEFER: EVAL
: eval-ast ( ast env -- ast )
{
{ [ over malsymbol? ] [ env-get ] }
{ [ over sequence? ] [ '[ _ EVAL ] map ] }
{ [ over assoc? ] [ '[ [ _ EVAL ] bi@ ] assoc-map ] }
[ drop ]
} cond ;
:: eval-def! ( key value env -- maltype )
value env EVAL [ key env env-set ] keep ;
: eval-let* ( bindings body env -- maltype env )
[ swap 2 group ] [ new-env ] bi* [
dup '[ first2 _ EVAL swap _ env-set ] each
] keep ;
:: eval-do ( exprs env -- lastform env/f )
exprs [
{ } f
] [
unclip-last [ env eval-ast drop ] dip env
] if-empty ;
:: eval-if ( params env -- maltype env/f )
params first env EVAL { f +nil+ } index not [
params second env
] [
params length 2 > [ params third env ] [ nil f ] if
] if ;
:: eval-fn* ( params env -- maltype )
env params first [ name>> ] map params second <malfn> ;
: args-split ( bindlist -- bindlist restbinding/f )
{ "&" } split1 ?first ;
: make-bindings ( args bindlist restbinding/f -- bindingshash )
swapd [ over length cut [ zip ] dip ] dip
[ swap 2array suffix ] [ drop ] if* >hashtable ;
GENERIC: apply ( args fn -- maltype newenv/f )
M: malfn apply
[ exprs>> nip ]
[ env>> nip ]
[ binds>> args-split make-bindings ] 2tri <malenv> ;
M: callable apply call( x -- y ) f ;
: READ ( str -- maltype ) read-str ;
: EVAL ( maltype env -- maltype )
over array? [
over first dup malsymbol? [ name>> ] when {
{ "def!" [ [ rest first2 ] dip eval-def! f ] }
{ "let*" [ [ rest first2 ] dip eval-let* ] }
{ "do" [ [ rest ] dip eval-do ] }
{ "if" [ [ rest ] dip eval-if ] }
{ "fn*" [ [ rest ] dip eval-fn* f ] }
[ drop '[ _ EVAL ] map unclip apply ]
} case
] [
eval-ast f
] if [ EVAL ] when* ;
: PRINT ( maltype -- str ) pr-str ;
: REP ( str -- str )
[ READ repl-env get EVAL ] [ nip ] recover PRINT ;
: REPL ( -- )
[
"user> " readline [
[ REP print flush ] unless-empty
] keep
] loop ;
f ns <malenv> repl-env set-global
"(def! not (fn* (a) (if a false true)))" REP drop
MAIN: REPL

0
factor/src/step6_file/deploy.factor → factor/step6_file/deploy.factor
View File

100
factor/step6_file/step6_file.factor Executable file
View File

@ -0,0 +1,100 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators command-line
continuations fry grouping hashtables io kernel lists locals
mal.core mal.env mal.printer mal.reader mal.types math
namespaces quotations readline sequences splitting ;
IN: step6_file
SYMBOL: repl-env
DEFER: EVAL
: eval-ast ( ast env -- ast )
{
{ [ over malsymbol? ] [ env-get ] }
{ [ over sequence? ] [ '[ _ EVAL ] map ] }
{ [ over assoc? ] [ '[ [ _ EVAL ] bi@ ] assoc-map ] }
[ drop ]
} cond ;
:: eval-def! ( key value env -- maltype )
value env EVAL [ key env env-set ] keep ;
: eval-let* ( bindings body env -- maltype env )
[ swap 2 group ] [ new-env ] bi* [
dup '[ first2 _ EVAL swap _ env-set ] each
] keep ;
:: eval-do ( exprs env -- lastform env/f )
exprs [
{ } f
] [
unclip-last [ env eval-ast drop ] dip env
] if-empty ;
:: eval-if ( params env -- maltype env/f )
params first env EVAL { f +nil+ } index not [
params second env
] [
params length 2 > [ params third env ] [ nil f ] if
] if ;
:: eval-fn* ( params env -- maltype )
env params first [ name>> ] map params second <malfn> ;
: args-split ( bindlist -- bindlist restbinding/f )
{ "&" } split1 ?first ;
: make-bindings ( args bindlist restbinding/f -- bindingshash )
swapd [ over length cut [ zip ] dip ] dip
[ swap 2array suffix ] [ drop ] if* >hashtable ;
GENERIC: apply ( args fn -- maltype newenv/f )
M: malfn apply
[ exprs>> nip ]
[ env>> nip ]
[ binds>> args-split make-bindings ] 2tri <malenv> ;
M: callable apply call( x -- y ) f ;
: READ ( str -- maltype ) read-str ;
: EVAL ( maltype env -- maltype )
over array? [
over first dup malsymbol? [ name>> ] when {
{ "def!" [ [ rest first2 ] dip eval-def! f ] }
{ "let*" [ [ rest first2 ] dip eval-let* ] }
{ "do" [ [ rest ] dip eval-do ] }
{ "if" [ [ rest ] dip eval-if ] }
{ "fn*" [ [ rest ] dip eval-fn* f ] }
[ drop '[ _ EVAL ] map unclip apply ]
} case [ EVAL ] when*
] [
eval-ast
] if ;
: PRINT ( maltype -- str ) pr-str ;
: REP ( str -- str )
[ READ repl-env get EVAL ] [ nip ] recover PRINT ;
: REPL ( -- )
[
"user> " readline [
[ REP print flush ] unless-empty
] keep
] loop ;
f ns clone
[ first repl-env get EVAL ] "eval" pick set-at
command-line get "*ARGV*" pick set-at
<malenv> repl-env set-global
"
(def! not (fn* (a) (if a false true)))
(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))
" string-lines harvest [ REP drop ] each
MAIN: REPL

0
factor/src/step7_quote/deploy.factor → factor/step7_quote/deploy.factor
View File

115
factor/step7_quote/step7_quote.factor Executable file
View File

@ -0,0 +1,115 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators
combinators.short-circuit command-line continuations fry
grouping hashtables io kernel lists locals mal.core mal.env
mal.printer mal.reader mal.types math namespaces quotations
readline sequences splitting ;
IN: step7_quote
SYMBOL: repl-env
DEFER: EVAL
: eval-ast ( ast env -- ast )
{
{ [ over malsymbol? ] [ env-get ] }
{ [ over sequence? ] [ '[ _ EVAL ] map ] }
{ [ over assoc? ] [ '[ [ _ EVAL ] bi@ ] assoc-map ] }
[ drop ]
} cond ;
:: eval-def! ( key value env -- maltype )
value env EVAL [ key env env-set ] keep ;
: eval-let* ( bindings body env -- maltype env )
[ swap 2 group ] [ new-env ] bi* [
dup '[ first2 _ EVAL swap _ env-set ] each
] keep ;
:: eval-do ( exprs env -- lastform env/f )
exprs [
{ } f
] [
unclip-last [ env eval-ast drop ] dip env
] if-empty ;
:: eval-if ( params env -- maltype env/f )
params first env EVAL { f +nil+ } index not [
params second env
] [
params length 2 > [ params third env ] [ nil f ] if
] if ;
:: eval-fn* ( params env -- maltype )
env params first [ name>> ] map params second <malfn> ;
: args-split ( bindlist -- bindlist restbinding/f )
{ "&" } split1 ?first ;
: make-bindings ( args bindlist restbinding/f -- bindingshash )
swapd [ over length cut [ zip ] dip ] dip
[ swap 2array suffix ] [ drop ] if* >hashtable ;
GENERIC: apply ( args fn -- maltype newenv/f )
M: malfn apply
[ exprs>> nip ]
[ env>> nip ]
[ binds>> args-split make-bindings ] 2tri <malenv> ;
M: callable apply call( x -- y ) f ;
: is-pair? ( maltype -- bool )
{ [ sequence? ] [ empty? not ] } 1&& ;
: quasiquote ( maltype -- maltype )
{
{ [ dup is-pair? not ] [ [ "quote" <malsymbol> ] dip 2array ] }
{ [ "unquote" over first symeq? ] [ second ] }
{ [ dup first { [ is-pair? ] [ first "splice-unquote" swap symeq? ] } 1&& ]
[ [ "concat" <malsymbol> ] dip unclip second swap quasiquote 3array ] }
[ "cons" <malsymbol> swap unclip quasiquote swap quasiquote 3array ]
} cond ;
: READ ( str -- maltype ) read-str ;
: EVAL ( maltype env -- maltype )
over array? [
over first dup malsymbol? [ name>> ] when {
{ "def!" [ [ rest first2 ] dip eval-def! f ] }
{ "let*" [ [ first2 ] dip eval-let* ] }
{ "do" [ [ rest ] dip eval-do ] }
{ "if" [ [ rest ] dip eval-if ] }
{ "fn*" [ [ rest ] dip eval-fn* f ] }
{ "quote" [ drop second f ] }
{ "quasiquote" [ [ second quasiquote ] dip ] }
[ drop '[ _ EVAL ] map unclip apply ]
} case [ EVAL ] when*
] [
eval-ast
] if ;
: PRINT ( maltype -- str ) pr-str ;
: REP ( str -- str )
[ READ repl-env get EVAL ] [ nip ] recover PRINT ;
: REPL ( -- )
[
"user> " readline [
[ REP print flush ] unless-empty
] keep
] loop ;
f ns clone
[ first repl-env get EVAL ] "eval" pick set-at
command-line get "*ARGV*" pick set-at
<malenv> repl-env set-global
"
(def! not (fn* (a) (if a false true)))
(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))
" string-lines harvest [ REP drop ] each
MAIN: REPL

0
factor/src/step8_macros/deploy.factor → factor/step8_macros/deploy.factor
View File

135
factor/step8_macros/step8_macros.factor Executable file
View File

@ -0,0 +1,135 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators
combinators.short-circuit command-line continuations fry
grouping hashtables io kernel lists locals mal.core mal.env
mal.printer mal.reader mal.types math namespaces quotations
readline sequences splitting ;
IN: step8_macros
SYMBOL: repl-env
DEFER: EVAL
: eval-ast ( ast env -- ast )
{
{ [ over malsymbol? ] [ env-get ] }
{ [ over sequence? ] [ '[ _ EVAL ] map ] }
{ [ over assoc? ] [ '[ [ _ EVAL ] bi@ ] assoc-map ] }
[ drop ]
} cond ;
:: eval-def! ( key value env -- maltype )
value env EVAL [ key env env-set ] keep ;
:: eval-defmacro! ( key value env -- maltype )
value env EVAL t >>macro? [ key env env-set ] keep ;
: eval-let* ( bindings body env -- maltype env )
[ swap 2 group ] [ new-env ] bi* [
dup '[ first2 _ EVAL swap _ env-set ] each
] keep ;
:: eval-do ( exprs env -- lastform env/f )
exprs [
{ } f
] [
unclip-last [ env eval-ast drop ] dip env
] if-empty ;
:: eval-if ( params env -- maltype env/f )
params first env EVAL { f +nil+ } index not [
params second env
] [
params length 2 > [ params third env ] [ nil f ] if
] if ;
:: eval-fn* ( params env -- maltype )
env params first [ name>> ] map params second <malfn> ;
: args-split ( bindlist -- bindlist restbinding/f )
{ "&" } split1 ?first ;
: make-bindings ( args bindlist restbinding/f -- bindingshash )
swapd [ over length cut [ zip ] dip ] dip
[ swap 2array suffix ] [ drop ] if* >hashtable ;
GENERIC: apply ( args fn -- maltype newenv/f )
M: malfn apply
[ exprs>> nip ]
[ env>> nip ]
[ binds>> args-split make-bindings ] 2tri <malenv> ;
M: callable apply call( x -- y ) f ;
: is-pair? ( maltype -- bool )
{ [ sequence? ] [ empty? not ] } 1&& ;
: quasiquote ( maltype -- maltype )
{
{ [ dup is-pair? not ] [ [ "quote" <malsymbol> ] dip 2array ] }
{ [ "unquote" over first symeq? ] [ second ] }
{ [ dup first { [ is-pair? ] [ first "splice-unquote" swap symeq? ] } 1&& ]
[ [ "concat" <malsymbol> ] dip unclip second swap quasiquote 3array ] }
[ "cons" <malsymbol> swap unclip swap [ quasiquote ] bi@ 3array ]
} cond ;
:: macro-expand ( maltype env -- maltype )
maltype dup array? [
dup first { [ malsymbol? ] [ env env-find drop ] } 1&& [
dup { [ malfn? ] [ macro?>> ] } 1&& [
[ rest ] dip apply [ EVAL ] keep macro-expand
] [ drop ] if
] when*
] when ;
: READ ( str -- maltype ) read-str ;
: EVAL ( maltype env -- maltype )
over array? [
[ macro-expand ] keep over array? [
over first dup malsymbol? [ name>> ] when {
{ "def!" [ [ rest first2 ] dip eval-def! f ] }
{ "defmacro!" [ [ rest first2 ] dip eval-defmacro! f ] }
{ "let*" [ [ rest first2 ] dip eval-let* ] }
{ "do" [ [ rest ] dip eval-do ] }
{ "if" [ [ rest ] dip eval-if ] }
{ "fn*" [ [ rest ] dip eval-fn* f ] }
{ "quote" [ drop second f ] }
{ "quasiquote" [ [ second quasiquote ] dip ] }
{ "macroexpand" [ [ second ] dip macro-expand f ] }
[ drop '[ _ EVAL ] map unclip apply ]
} case [ EVAL ] when*
] [
drop
] if
] [
eval-ast
] if ;
: PRINT ( maltype -- str ) pr-str ;
: REP ( str -- str )
[ READ repl-env get EVAL ] [ nip ] recover PRINT ;
: REPL ( -- )
[
"user> " readline [
[ REP print flush ] unless-empty
] keep
] loop ;
f ns clone
[ first repl-env get EVAL ] "eval" pick set-at
command-line get "*ARGV*" pick set-at
<malenv> repl-env set-global
"
(def! not (fn* (a) (if a false true)))
(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))
(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))
(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))
" string-lines harvest [ REP drop ] each
MAIN: REPL

0
factor/src/step9_try/.step8_macros.factor.swp → factor/step9_try/.step8_macros.factor.swp
View File

0
factor/src/step9_try/deploy.factor → factor/step9_try/deploy.factor
View File

145
factor/step9_try/step9_try.factor Executable file
View File

@ -0,0 +1,145 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators
combinators.short-circuit command-line continuations fry
grouping hashtables io kernel lists locals mal.core mal.env
mal.printer mal.reader mal.types math namespaces quotations
readline sequences splitting ;
IN: step9_try
SYMBOL: repl-env
DEFER: EVAL
: eval-ast ( ast env -- ast )
{
{ [ over malsymbol? ] [ env-get ] }
{ [ over sequence? ] [ '[ _ EVAL ] map ] }
{ [ over assoc? ] [ '[ [ _ EVAL ] bi@ ] assoc-map ] }
[ drop ]
} cond ;
:: eval-def! ( key value env -- maltype )
value env EVAL [ key env env-set ] keep ;
:: eval-defmacro! ( key value env -- maltype )
value env EVAL t >>macro? [ key env env-set ] keep ;
: eval-let* ( bindings body env -- maltype env )
[ swap 2 group ] [ new-env ] bi* [
dup '[ first2 _ EVAL swap _ env-set ] each
] keep ;
:: eval-do ( exprs env -- lastform env/f )
exprs [
{ } f
] [
unclip-last [ env eval-ast drop ] dip env
] if-empty ;
:: eval-if ( params env -- maltype env/f )
params first env EVAL { f +nil+ } index not [
params second env
] [
params length 2 > [ params third env ] [ nil f ] if
] if ;
:: eval-fn* ( params env -- maltype )
env params first [ name>> ] map params second <malfn> ;
:: eval-try* ( params env -- maltype )
[ params first env EVAL ]
[
params second second env new-env [ env-set ] keep
params second third swap EVAL
] recover ;
: args-split ( bindlist -- bindlist restbinding/f )
{ "&" } split1 ?first ;
: make-bindings ( args bindlist restbinding/f -- bindingshash )
swapd [ over length cut [ zip ] dip ] dip
[ swap 2array suffix ] [ drop ] if* >hashtable ;
GENERIC: apply ( args fn -- maltype newenv/f )
M: malfn apply
[ exprs>> nip ]
[ env>> nip ]
[ binds>> args-split make-bindings ] 2tri <malenv> ;
M: callable apply call( x -- y ) f ;
: is-pair? ( maltype -- bool )
{ [ sequence? ] [ empty? not ] } 1&& ;
: quasiquote ( maltype -- maltype )
{
{ [ dup is-pair? not ] [ [ "quote" <malsymbol> ] dip 2array ] }
{ [ "unquote" over first symeq? ] [ second ] }
{ [ dup first { [ is-pair? ] [ first "splice-unquote" swap symeq? ] } 1&& ]
[ [ "concat" <malsymbol> ] dip unclip second swap quasiquote 3array ] }
[ "cons" <malsymbol> swap unclip swap [ quasiquote ] bi@ 3array ]
} cond ;
:: macro-expand ( maltype env -- maltype )
maltype dup array? [
dup first { [ malsymbol? ] [ env env-find drop ] } 1&& [
dup { [ malfn? ] [ macro?>> ] } 1&& [
[ rest ] dip apply [ EVAL ] keep macro-expand
] [ drop ] if
] when*
] when ;
: READ ( str -- maltype ) read-str ;
: EVAL ( maltype env -- maltype )
over array? [
[ macro-expand ] keep over array? [
over first dup malsymbol? [ name>> ] when {
{ "def!" [ [ rest first2 ] dip eval-def! f ] }
{ "defmacro!" [ [ rest first2 ] dip eval-defmacro! f ] }
{ "let*" [ [ rest first2 ] dip eval-let* ] }
{ "do" [ [ rest ] dip eval-do ] }
{ "if" [ [ rest ] dip eval-if ] }
{ "fn*" [ [ rest ] dip eval-fn* f ] }
{ "quote" [ drop second f ] }
{ "quasiquote" [ [ second quasiquote ] dip ] }
{ "macroexpand" [ [ second ] dip macro-expand f ] }
{ "try*" [ [ rest ] dip eval-try* f ] }
[ drop '[ _ EVAL ] map unclip apply ]
} case [ EVAL ] when*
] [
drop
] if
] [
eval-ast
] if ;
[ apply [ EVAL ] when* ] mal-apply set-global
: PRINT ( maltype -- str ) pr-str ;
: REP ( str -- str )
[ READ repl-env get EVAL ] [ nip ] recover PRINT ;
: REPL ( -- )
[
"user> " readline [
[ REP print flush ] unless-empty
] keep
] loop ;
f ns clone
[ first repl-env get EVAL ] "eval" pick set-at
command-line get "*ARGV*" pick set-at
<malenv> repl-env set-global
"
(def! not (fn* (a) (if a false true)))
(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))
(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))
(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))
" string-lines harvest [ REP drop ] each
MAIN: REPL

0
factor/src/stepA_mal/deploy.factor → factor/stepA_mal/deploy.factor
View File

153
factor/stepA_mal/stepA_mal.factor Executable file
View File

@ -0,0 +1,153 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators
combinators.short-circuit command-line continuations fry
grouping hashtables io kernel lists locals mal.core mal.env
mal.printer mal.reader mal.types math namespaces quotations
readline sequences splitting strings ;
IN: stepA_mal
SYMBOL: repl-env
DEFER: EVAL
: eval-ast ( ast env -- ast )
{
{ [ over malsymbol? ] [ env-get ] }
{ [ over sequence? ] [ '[ _ EVAL ] map ] }
{ [ over assoc? ] [ '[ [ _ EVAL ] bi@ ] assoc-map ] }
[ drop ]
} cond ;
:: eval-def! ( key value env -- maltype )
value env EVAL [ key env env-set ] keep ;
:: eval-defmacro! ( key value env -- maltype )
value env EVAL t >>macro? [ key env env-set ] keep ;
: eval-let* ( bindings body env -- maltype env )
[ swap 2 group ] [ new-env ] bi* [
dup '[ first2 _ EVAL swap _ env-set ] each
] keep ;
:: eval-do ( exprs env -- lastform env/f )
exprs [
{ } f
] [
unclip-last [ env eval-ast drop ] dip env
] if-empty ;
:: eval-if ( params env -- maltype env/f )
params first env EVAL { f +nil+ } index not [
params second env
] [
params length 2 > [ params third env ] [ nil f ] if
] if ;
:: eval-fn* ( params env -- maltype )
env params first [ name>> ] map params second <malfn> ;
:: eval-try* ( params env -- maltype )
[ params first env EVAL ]
[
params second second env new-env [ env-set ] keep
params second third swap EVAL
] recover ;
: args-split ( bindlist -- bindlist restbinding/f )
{ "&" } split1 ?first ;
: make-bindings ( args bindlist restbinding/f -- bindingshash )
swapd [ over length cut [ zip ] dip ] dip
[ swap 2array suffix ] [ drop ] if* >hashtable ;
GENERIC: apply ( args fn -- maltype newenv/f )
M: malfn apply
[ exprs>> nip ]
[ env>> nip ]
[ binds>> args-split make-bindings ] 2tri <malenv> ;
M: callable apply call( x -- y ) f ;
: is-pair? ( maltype -- ? )
{ [ sequence? ] [ string? not ] [ empty? not ] } 1&& ;
: quasiquote ( maltype -- maltype )
{
{ [ dup is-pair? not ] [ [ "quote" <malsymbol> ] dip 2array ] }
{ [ "unquote" over first symeq? ] [ second ] }
{ [ dup first { [ is-pair? ] [ first "splice-unquote" swap symeq? ] } 1&& ]
[ [ "concat" <malsymbol> ] dip unclip second swap quasiquote 3array ] }
[ "cons" <malsymbol> swap unclip swap [ quasiquote ] bi@ 3array ]
} cond ;
:: macro-expand ( maltype env -- maltype )
maltype dup array? [
dup first { [ malsymbol? ] [ env env-find drop ] } 1&& [
dup { [ malfn? ] [ macro?>> ] } 1&& [
[ rest ] dip apply [ EVAL ] keep macro-expand
] [ drop ] if
] when*
] when ;
: READ ( str -- maltype ) read-str ;
: EVAL ( maltype env -- maltype )
over array? [
[ macro-expand ] keep over array? [
over first dup malsymbol? [ name>> ] when {
{ "def!" [ [ rest first2 ] dip eval-def! f ] }
{ "defmacro!" [ [ rest first2 ] dip eval-defmacro! f ] }
{ "let*" [ [ rest first2 ] dip eval-let* ] }
{ "do" [ [ rest ] dip eval-do ] }
{ "if" [ [ rest ] dip eval-if ] }
{ "fn*" [ [ rest ] dip eval-fn* f ] }
{ "quote" [ drop second f ] }
{ "quasiquote" [ [ second quasiquote ] dip ] }
{ "macroexpand" [ [ second ] dip macro-expand f ] }
{ "try*" [ [ rest ] dip eval-try* f ] }
[ drop '[ _ EVAL ] map unclip apply ]
} case [ EVAL ] when*
] [
drop
] if
] [
eval-ast
] if ;
[ apply [ EVAL ] when* ] mal-apply set-global
: PRINT ( maltype -- str ) pr-str ;
: REP ( str -- str )
[ READ repl-env get EVAL ] [ nip ] recover PRINT ;
: REPL ( -- )
"(println (str \"Mal [\" *host-language* \"]\"))" REP drop
[
"user> " readline [
[ REP print flush ] unless-empty
] keep
] loop ;
: main ( -- )
command-line get
[ REPL ]
[ first "(load-file \"" "\")" surround REP print flush ]
if-empty ;
f ns clone
[ first repl-env get EVAL ] "eval" pick set-at
command-line get dup empty? [ rest ] unless "*ARGV*" pick set-at
<malenv> repl-env set-global
"
(def! *host-language* \"factor\")
(def! not (fn* (a) (if a false true)))
(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))
(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))
(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))
" string-lines harvest [ READ repl-env get EVAL drop ] each
MAIN: main