factor: step 4 complete

Added core.factor, including math comparison operations, list operations
and string operations.

diff --git a/factor/src/core/core.factor b/factor/src/core/core.factor
new file mode 100644 (file)
index 0000000..6dd2f4d
--- /dev/null
+++ b/factor/src/core/core.factor
@@ -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 ] }
+             }

diff --git a/factor/src/printer/printer.factor b/factor/src/printer/printer.factor
index 145ef01..1c4f49c 100644 (file)
--- a/factor/src/printer/printer.factor
+++ b/factor/src/printer/printer.factor
@@ -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) ;

diff --git a/factor/src/step4_if_fn_do/step4_if_fn_do.factor b/factor/src/step4_if_fn_do/step4_if_fn_do.factor
index 4facc9c..92f51fb 100755 (executable)
--- a/factor/src/step4_if_fn_do/step4_if_fn_do.factor
+++ b/factor/src/step4_if_fn_do/step4_if_fn_do.factor
@@ -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