mirror of
https://github.com/kanaka/mal.git
synced 2024-09-11 13:55:55 +03:00
factor: update code.
* 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:
parent
953772ca00
commit
199b1ce7b2
2
Makefile
2
Makefile
@ -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))
|
||||
|
@ -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
|
||||
|
@ -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
74
factor/mal/core/core.factor
Normal 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
32
factor/mal/env/env.factor
vendored
Normal 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
31
factor/mal/printer/printer.factor
Normal 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
65
factor/mal/reader/reader.factor
Normal 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
34
factor/mal/types/types.factor
Normal 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 ;
|
@ -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 ] }
|
||||
}
|
@ -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 ;
|
@ -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) ;
|
@ -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 ;
|
||||
|
@ -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
|
@ -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
|
@ -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
|
@ -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
|
@ -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
|
@ -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
|
@ -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
|
@ -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
|
@ -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
|
@ -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
|
@ -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
|
@ -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
|
21
factor/step0_repl/step0_repl.factor
Executable file
21
factor/step0_repl/step0_repl.factor
Executable 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
|
23
factor/step1_read_print/step1_read_print.factor
Executable file
23
factor/step1_read_print/step1_read_print.factor
Executable 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
|
55
factor/step2_eval/step2_eval.factor
Executable file
55
factor/step2_eval/step2_eval.factor
Executable 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
|
68
factor/step3_env/step3_env.factor
Executable file
68
factor/step3_env/step3_env.factor
Executable 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
|
86
factor/step4_if_fn_do/step4_if_fn_do.factor
Executable file
86
factor/step4_if_fn_do/step4_if_fn_do.factor
Executable 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
|
94
factor/step5_tco/step5_tco.factor
Executable file
94
factor/step5_tco/step5_tco.factor
Executable 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
|
100
factor/step6_file/step6_file.factor
Executable file
100
factor/step6_file/step6_file.factor
Executable 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
|
115
factor/step7_quote/step7_quote.factor
Executable file
115
factor/step7_quote/step7_quote.factor
Executable 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
|
135
factor/step8_macros/step8_macros.factor
Executable file
135
factor/step8_macros/step8_macros.factor
Executable 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
|
145
factor/step9_try/step9_try.factor
Executable file
145
factor/step9_try/step9_try.factor
Executable 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
|
153
factor/stepA_mal/stepA_mal.factor
Executable file
153
factor/stepA_mal/stepA_mal.factor
Executable 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
|
Loading…
Reference in New Issue
Block a user