kanaka/mal
1
1
Fork 0
mirror of https://github.com/kanaka/mal.git synced 2024-11-10 12:47:45 +03:00
Code Issues Projects Releases Wiki Activity

factor: step 4 complete

Browse Source 
Added core.factor, including math comparison operations, list operations
and string operations.
This commit is contained in:
Jordan Lewis 2015-03-16 22:51:59 -04:00
parent 24bd218ea1
commit d672e7e9fb
3 changed files with 54 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
factor/src/core/core.factor Normal file
View File

@ -0,0 +1,27 @@
! Copyright (C) 2015 Jordan Lewis.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences arrays lists printer locals io strings ;
IN: core
:: pr-str-stack ( printer-quot glue -- str )
datastack printer-quot map glue join ; inline
CONSTANT: ns H{ { "+" [ + ] }
{ "-" [ - ] }
{ "*" [ * ] }
{ "/" [ / ] }
{ "list" [ datastack >array ] }
{ "list?" [ array? ] }
{ "empty?" [ empty? ] }
{ "count" [ dup nil? [ drop 0 ] [ length ] if ] }
{ "=" [ 2dup [ [ sequence? ] [ string? not ] bi and ] bi@ and [ sequence= ] [ = ] if ] }
{ "<" [ < ] }
{ ">" [ > ] }
{ ">=" [ >= ] }
{ "<=" [ <= ] }
{ "pr-str" [ [ t (pr-str) ] " " pr-str-stack ] }
{ "str" [ [ f (pr-str) ] "" pr-str-stack ] }
{ "prn" [ [ t (pr-str) ] " " pr-str-stack print nil ] }
{ "println" [ [ f (pr-str) ] " " pr-str-stack print nil ] }
}

24
factor/src/printer/printer.factor
View File

@ -1,27 +1,33 @@
! 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 ;
hashtables assocs combinators.short-circuit regexp quotations locals ;
IN: printer
: pr-str-str ( str -- str )
dup { [ empty? not ] [ 1 head "\u00029e" = ] } 1&&
:: pr-str-str ( str readably? -- str )
str dup { [ empty? not ] [ 1 head "\u00029e" = ] } 1&&
[ rest ":" prepend ]
[ R/ "/ "\\\"" re-replace "\"" dup surround ]
[ readably? [ R/ \/ "\\\\" re-replace
R/ "/ """\\"""" re-replace
"\"" dup surround ] when ]
if ;
: pr-str ( maltype -- str )
:: (pr-str) ( maltype readably? -- str )
maltype
{
{ [ dup malsymbol? ] [ name>> ] }
{ [ dup number? ] [ number>string ] }
{ [ dup string? ] [ pr-str-str ] }
{ [ dup array? ] [ [ pr-str ] map " " join "(" ")" surround ] }
{ [ dup vector? ] [ [ pr-str ] map " " join "[" "]" surround ] }
{ [ 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
[ [ pr-str ] bi@ " " glue ] [ " " glue ] 2map-reduce
[ [ readably? (pr-str) ] bi@ " " glue ] [ " " glue ] 2map-reduce
"{" "}" surround ] }
{ [ dup callable? ] [ drop "#<fn>" ] }
{ [ dup t = ] [ drop "true" ] }
{ [ dup f = ] [ drop "false" ] }
{ [ dup nil = ] [ drop "nil" ] }
} cond ;
: pr-str ( maltype -- str )
t (pr-str) ;

23
factor/src/step4_if_fn_do/step4_if_fn_do.factor
View File

@ -2,14 +2,10 @@
! 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 ;
types splitting core ;
IN: step4_if_fn_do
CONSTANT: repl-bindings H{ { "+" [ + ] }
{ "-" [ - ] }
{ "*" [ * ] }
{ "/" [ / ] } }
SYMBOL: repl-env
DEFER: EVAL
@ -39,10 +35,14 @@ DEFER: EVAL
} cond ;
:: eval-fn* ( params env -- maltype )
[ datastack params first [ name>> ] map [ length tail* ] keep swap zip >hashtable
env swap <malenv>
params second swap
EVAL ] ;
params first [ name>> ] map [ "&" ] split { } suffix first2
'[ datastack _ [ length cut-slice ] keep ! head tail firstparams
swap [ swap zip ] dip ! bindalist tail
_ dup empty? [ 2drop ] [ first swap >array 2array suffix ] if
>hashtable
env swap <malenv>
params second swap
EVAL ] ;
: READ ( str -- maltype ) read-str ;
:: EVAL ( maltype env -- maltype )
@ -63,12 +63,13 @@ DEFER: EVAL
: 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
f ns <malenv> repl-env set-global
"(def! not (fn* (a) (if a false true)))" rep drop
MAIN: main-loop