factor: step A

missing collection metadata

factor/src/core/core.factor

@@ -1,7 +1,8 @@
 ! 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 ;
+       fry types combinators.short-circuit vectors hashtables assocs hash-sets sets grouping namespaces accessors
+       combinators readline ;
 
 IN: core
 
@@ -30,8 +31,8 @@ CONSTANT: ns H{ { "+" [ first2 + ] }
                 { "<=" [ first2 <= ] }
                 { "pr-str" [ t " " pr-str-stack ] }
                 { "str" [ f "" pr-str-stack ] }
-                { "prn" [ t " " pr-str-stack print nil ] }
-                { "println" [ f " " pr-str-stack print nil ] }
+                { "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 ] }
@@ -60,4 +61,15 @@ CONSTANT: ns H{ { "+" [ first2 + ] }
                 { "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 ] }
              }

factor/src/printer/printer.factor

@@ -27,6 +27,7 @@ IN: printer
         { [ dup t = ]        [ drop "true" ] }
         { [ dup f = ]        [ drop "false" ] }
         { [ dup nil = ]      [ drop "nil" ] }
+        { [ dup malatom? ]   [ val>> readably? (pr-str) "(atom " ")" surround ] }
         [ summary ]
     } cond ;
 

factor/src/stepA_mal/deploy.factor

@@ -0,0 +1,16 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-c-types? f }
+    { deploy-help? f }
+    { deploy-name "stepA_mal" }
+    { "stop-after-last-window?" t }
+    { deploy-unicode? f }
+    { deploy-console? t }
+    { deploy-io 3 }
+    { deploy-reflection 1 }
+    { deploy-ui? f }
+    { deploy-word-defs? f }
+    { deploy-threads? t }
+    { deploy-math? t }
+    { deploy-word-props? f }
+}

factor/src/stepA_mal/stepA_mal.factor

@@ -0,0 +1,149 @@
+! 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 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 ] }
+        [ 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 ;
+
+: run-or-repl ( -- )
+    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 "*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: run-or-repl

factor/src/types/types.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2015 Jordan Lewis.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: regexp strings kernel sequences math.parser accessors malenv ;
+USING: regexp strings kernel sequences math.parser accessors malenv assocs ;
 IN: types
 
 TUPLE: malsymbol { name string read-only } ;
@@ -12,9 +12,14 @@ C: <malsymbol> malsymbol
 TUPLE: fn { env malenv read-only }
           { binds sequence read-only }
           { exprs read-only }
-          { is-macro boolean } ;
+          { is-macro boolean }
+          { meta assoc } ;
 
 C: (<fn>) fn
 
 : <fn> ( env binds exprs -- fn )
-    f (<fn>) ;
+    f f (<fn>) ;
+
+TUPLE: malatom { val } ;
+
+C: <malatom> malatom