forth: Added lists, ints, symbols for step 1

6 files changed, 337 insertions, 178 deletions

diff --git a/forth/misc-tests.fs b/forth/misc-tests.fs
new file mode 100644
index 0000000..5aaf2f2
--- /dev/null
+++ b/forth/misc-tests.fs
@@ -0,0 +1,53 @@
+require printer.fs
+
+\ === basic testing util === /
+: test=
+  2dup = if
+    2drop
+  else
+    cr ." assert failed on line " sourceline# .
+    swap cr ." | got " . cr ." | expected " . cr
+  endif ;
+
+\ array function tests
+create za 2 , 6 , 7 , 10 , 15 , 80 , 81 ,
+
+7 za 2 array-find   -1 test= 0 test=
+7 za 6 array-find   -1 test= 1 test=
+7 za 10 array-find  -1 test= 3 test=
+7 za 81 array-find  -1 test= 6 test=
+7 za 12 array-find   0 test= 4 test=
+7 za 8  array-find   0 test= 3 test=
+7 za 100 array-find  0 test= 7 test=
+7 za 1 array-find    0 test= 0 test=
+
+10 new-array
+1 swap 0  5 array-insert
+2 swap 1  7 array-insert
+3 swap 3 12 array-insert
+4 swap 4 15 array-insert
+5 swap 5 20 array-insert
+
+dup 0 cells + @   5 test=
+dup 1 cells + @   7 test=
+dup 2 cells + @  10 test=
+dup 3 cells + @  12 test=
+dup 4 cells + @  15 test=
+dup 5 cells + @  20 test=
+
+
+\ MalType tests
+
+MalList new   MalList new   = 0 test=
+
+MalList new dup MalList/car 5 swap ! MalList/car @   5 test=
+
+
+\ Protocol tests
+
+mal-nil
+42 MalInt. mal-nil conj
+10 MalInt. mal-nil conj conj
+20 MalInt. swap conj
+23 MalInt. mal-nil conj conj conj
+pr-str s" (nil (20 (42) 10) 23)" str= -1 test=
diff --git a/forth/printer.fs b/forth/printer.fs
new file mode 100644
index 0000000..5ff28e5
--- /dev/null
+++ b/forth/printer.fs
@@ -0,0 +1,96 @@
+require types.fs
+
+: safe-type ( str-addr str-len -- )
+    dup 256 > if
+        drop 256 type ." ...<lots more>" type
+    else
+        type
+    endif ;
+
+\ === mutable string buffer === /
+\ string buffer that maintains an allocation larger than the current
+\ string size.  When appending would cause the string size exceed the
+\ current allocation, resize is used to double the allocation. The
+\ current allocation is not stored anywhere, but computed based on
+\ current string size or str-base-size, whichever is larger.
+64 constant str-base-size
+
+: new-str ( -- addr length )
+  str-base-size allocate throw 0 ;
+
+: round-up ( n -- n )
+  2
+  begin
+    1 lshift 2dup <
+  until
+  swap drop ;
+
+: str-append { buf-addr buf-str-len str-addr str-len }
+  buf-str-len str-len +
+  { new-len }
+  new-len str-base-size > if
+    buf-str-len new-len xor buf-str-len > if
+      buf-addr new-len round-up resize throw
+      to buf-addr
+    endif
+  endif
+  str-addr buf-addr buf-str-len + str-len cmove
+  buf-addr new-len ;
+
+\ define a-space, to append a space char to a string
+bl c,
+here constant space-str
+: a-space space-str 1 str-append ;
+
+: str-append-char ( buf-addr buf-str-len char -- buf-addr buf-str-len )
+    pad ! pad 1 str-append ; \ refactoring str-append could perhaps make this faster
+
+: int>str ( num -- str-addr str-len )
+  s>d <# #s #> ;
+
+
+\ === printer protocol and implementations === /
+
+def-protocol-method pr-buf ( str-addr str-len this -- str-addr str-len )
+
+: pr-str { obj }
+    new-str obj pr-buf ;
+
+\ Examples of extending existing protocol methods to existing type
+MalDefault
+  extend pr-buf
+    { this }
+    s" #<MalObject" str-append a-space
+    this int>str str-append
+    s" >" str-append ;;
+drop
+
+MalNil
+  extend pr-buf
+    drop s" nil" str-append ;;
+drop
+
+MalList
+  extend pr-buf
+    -rot s" (" str-append ( list str-addr str-len )
+    rot dup MalList/cdr @ swap MalList/car @ 2swap rot pr-buf
+    begin ( list str-addr str-len )
+      2 pick mal-nil <>
+    while
+      a-space
+      rot dup MalList/cdr @ swap MalList/car @ 2swap rot pr-buf
+    repeat
+    s" )" str-append rot drop ;;
+drop
+
+MalInt
+  extend pr-buf
+    MalInt/int @ int>str str-append ;;
+drop
+
+MalSymbol
+  extend pr-buf
+    dup MalSymbol/sym-addr @
+    swap MalSymbol/sym-len @
+    str-append ;;
+drop
diff --git a/forth/reader.fs b/forth/reader.fs
new file mode 100644
index 0000000..6ed9fb5
--- /dev/null
+++ b/forth/reader.fs
@@ -0,0 +1,92 @@
+require types.fs
+require printer.fs
+
+\ Drop a char off the front of string by advancing the addr and
+\ decrementing the length, and fetch next char
+: adv-str ( str-addr str-len -- str-addr str-len char )
+    swap 1+ swap 1-
+    dup 0= if 0 ( eof )
+    else over c@ endif ;
+
+: skip-spaces ( str-addr str-len char -- str-addr str-len non-space-char )
+    begin
+        dup bl =
+    while ( str-addr str-len space-char )
+        drop adv-str
+    repeat ;
+
+: mal-digit? ( char -- flag )
+    dup [char] 9 <= if
+        [char] 0 >=
+    else
+        drop 0
+    endif ;
+
+: char-in-str? ( char str-addr str-len )
+    rot { needle }
+    begin ( str-addr str-len )
+        adv-str needle = if
+            2drop -1 -1 \ success! drop and exit
+        else
+            dup 0= if
+                2drop 0 -1 \ str consumed, char not found.
+            else
+                0 \ continue
+            endif
+        endif
+    until ;
+
+s\" []{}()'\"`,; " constant non-sym-chars-len constant non-sym-chars
+: sym-char? ( char -- flag )
+    non-sym-chars non-sym-chars-len char-in-str? 0= ;
+
+defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
+
+: read-int ( str-addr str-len digit-char -- str-addr str-len non-digit-char mal-int )
+    0 { int }
+    begin ( str-addr str-len digit-char )
+        [char] 0 - int 10 * + to int ( str-addr str-len )
+        adv-str dup mal-digit? 0= ( str-addr str-len digit-char )
+    until
+    int MalInt. ;
+
+: read-symbol-str ( str-addr str-len sym-char -- str-addr str-len sym-addr sym-len )
+    new-str { sym-addr sym-len }
+    begin ( str-addr srt-len sym-char )
+        sym-addr sym-len rot str-append-char to sym-len to sym-addr
+        adv-str dup sym-char? 0=
+    until
+    sym-addr sym-len ;
+
+: read-list ( str-addr str-len open-paren-char -- str-addr str-len non-paren-char mal-list )
+    \ push objects onto "dictionary" -- maybe not the best stack for this?
+    0 { len }
+    drop adv-str
+    begin ( str-addr str-len char )
+        skip-spaces ( str-addr str-len non-space-char )
+        dup [char] ) <>
+    while ( str-addr str-len non-space-non-paren-char )
+        read-form , len 1+ to len
+    repeat
+    drop adv-str
+
+    \ pop objects out of "dictionary" into MalList
+    mal-nil
+    len 0 ?do
+        0 cell - allot
+        here @ swap conj
+    loop
+    ;
+
+: read-form2 ( str-addr str-len char -- str-addr str-len mal-obj )
+    skip-spaces
+    dup mal-digit? if read-int else
+        dup [char] ( = if read-list else
+            read-symbol-str MalSymbol.
+        endif
+    endif
+    ;
+' read-form2 is read-form
+
+: read-str ( str-addr str-len - mal-obj )
+    over c@ read-form -rot 2drop ;
diff --git a/forth/step0_repl.fs b/forth/step0_repl.fs
index 42c33f5..2483c12 100644
--- a/forth/step0_repl.fs
+++ b/forth/step0_repl.fs
@@ -1,4 +1,4 @@
-s" types.fs" included
+require types.fs
 
 : read ;
 : eval ;
diff --git a/forth/step1_read_print.fs b/forth/step1_read_print.fs
new file mode 100644
index 0000000..9fe1470
--- /dev/null
+++ b/forth/step1_read_print.fs
@@ -0,0 +1,32 @@
+require reader.fs
+require printer.fs
+
+: read read-str ;
+: eval ;
+: print pr-str ;
+
+: rep
+    read
+    eval
+    print ;
+
+create buff 128 allot
+
+: read-lines
+    begin
+      ." user> "
+      buff 128 stdin read-line throw
+    while
+      buff swap
+      rep safe-type cr
+    repeat ;
+
+\ s" 1   (42 1 (2 12 8)) 35" swap 1+ swap .s read-str .s
+\ s" 7" .s read-str .s
+\ cr
+\ pr-str safe-type cr
+\ new-str s" hello" str-append char ! str-append-char safe-type
+
+read-lines
+cr
+bye
diff --git a/forth/types.fs b/forth/types.fs
index 460c3aa..2b74576 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -1,119 +1,3 @@
-\ === tiny framework for inline tests === /
-: test=
-  2dup = if
-    2drop
-  else
-    cr ." assert failed on line " sourceline# .
-    swap cr ." | got " . cr ." | expected " . cr
-  endif ;
-
-: safe-type ( str-addr str-len -- )
-    dup 256 > if
-        drop 256 type ." ...<lots more>" type
-    else
-        type
-    endif ;
-
-
-\ === mutable string buffer === /
-\ string buffer that maintains an allocation larger than the current
-\ string size.  When appending would cause the string size exceed the
-\ current allocation, resize is used to double the allocation. The
-\ current allocation is not stored anywhere, but computed based on
-\ current string size or str-base-size, whichever is larger.
-64 constant str-base-size
-
-: new-str ( -- addr length )
-  str-base-size allocate throw 0 ;
-
-: round-up ( n -- n )
-  2
-  begin
-    1 lshift 2dup <
-  until
-  swap drop ;
-
-: str-append { buf-addr buf-str-len str-addr str-len }
-  buf-str-len str-len +
-  { new-len }
-  new-len str-base-size > if
-    buf-str-len new-len xor buf-str-len > if
-      buf-addr new-len round-up resize throw
-      to buf-addr
-    endif
-  endif
-  str-addr buf-addr buf-str-len + str-len cmove
-  buf-addr new-len ;
-
-\ define a function to append a space
-bl c,
-here constant space-str
-: a-space space-str 1 str-append ;
-
-: int>str ( num -- str-addr str-len )
-  s>d <# #s #> ;
-
-
-\ === deftype* -- protocol-enabled structs === /
-\ Each type has MalTypeType% struct allocated on the stack, with
-\ mutable fields pointing to all class-shared resources, specifically
-\ the data needed to allocate new instances, and the table of protocol
-\ methods that have been extended to the type.
-\ Use 'deftype*' to define a new type, and 'new' to create new
-\ instances of that type.
-
-struct
-  cell% field mal-type
-  \ cell% field ref-count \ Ha, right.
-end-struct MalType%
-
-struct
-  cell% 2 * field MalTypeType-struct
-  cell% field MalTypeType-methods
-  cell% field MalTypeType-method-keys
-  cell% field MalTypeType-method-vals
-end-struct MalTypeType%
-
-: new ( MalTypeType -- obj )
-  dup MalTypeType-struct 2@ %allocate throw ( MalTypeType obj ) \ create struct
-  dup -rot mal-type !                       ( obj ) \ set struct's type pointer to this type
-  ;
-
-: deftype* ( struct-align struct-len -- MalTypeType )
-  MalTypeType% %allot                      ( s-a s-l MalTypeType )
-  dup 2swap rot                            ( MalTypeType s-a s-l MalTypeType )
-  MalTypeType-struct 2!                    ( MalTypeType ) \ store struct info
-  dup MalTypeType-methods     0   swap !   ( MalTypeType )
-  dup MalTypeType-method-keys nil swap !   ( MalTypeType )
-  dup MalTypeType-method-vals nil swap !   ( MalTypeType )
-  ;
-
-MalType% deftype* constant MalDefault
-
-\ nil type and instance to support extending protocols to it
-MalType% deftype* constant MalNil
-MalNil new constant mal-nil
-
-\ Example and tests
-
-MalType%
-  cell% field MalList/car
-  cell% field MalList/cdr
-deftype* constant MalList
-
-: MalList/conj { val coll -- list }
-    MalList new ( list )
-    val over MalList/car ! ( list )
-    coll over MalList/cdr ! ( list )
-    ;
-
-MalList new
-MalList new
-= 0 test=
-
-MalList new dup MalList/car 5 swap ! MalList/car @   5 test=
-
-
 \ === sorted-array === /
 \ Here are a few utility functions useful for creating and maintaining
 \ the deftype* method tables. The keys array is kept in sorted order,
@@ -162,32 +46,46 @@ MalList new dup MalList/car 5 swap ! MalList/car @   5 test=
   a
   ;
 
-\ array function tests
-create za 2 , 6 , 7 , 10 , 15 , 80 , 81 ,
-
-7 za 2 array-find   -1 test= 0 test=
-7 za 6 array-find   -1 test= 1 test=
-7 za 10 array-find  -1 test= 3 test=
-7 za 81 array-find  -1 test= 6 test=
-7 za 12 array-find   0 test= 4 test=
-7 za 8  array-find   0 test= 3 test=
-7 za 100 array-find  0 test= 7 test=
-7 za 1 array-find    0 test= 0 test=
-
-10 new-array
-1 swap 0  5 array-insert
-2 swap 1  7 array-insert
-3 swap 3 12 array-insert
-4 swap 4 15 array-insert
-5 swap 5 20 array-insert
-
-dup 0 cells + @   5 test=
-dup 1 cells + @   7 test=
-dup 2 cells + @  10 test=
-dup 3 cells + @  12 test=
-dup 4 cells + @  15 test=
-dup 5 cells + @  20 test=
 
+\ === deftype* -- protocol-enabled structs === /
+\ Each type has MalTypeType% struct allocated on the stack, with
+\ mutable fields pointing to all class-shared resources, specifically
+\ the data needed to allocate new instances, and the table of protocol
+\ methods that have been extended to the type.
+\ Use 'deftype*' to define a new type, and 'new' to create new
+\ instances of that type.
+
+struct
+  cell% field mal-type
+  \ cell% field ref-count \ Ha, right.
+end-struct MalType%
+
+struct
+  cell% 2 * field MalTypeType-struct
+  cell% field MalTypeType-methods
+  cell% field MalTypeType-method-keys
+  cell% field MalTypeType-method-vals
+end-struct MalTypeType%
+
+: new ( MalTypeType -- obj )
+  dup MalTypeType-struct 2@ %allocate throw ( MalTypeType obj ) \ create struct
+  dup -rot mal-type !                       ( obj ) \ set struct's type pointer to this type
+  ;
+
+: deftype* ( struct-align struct-len -- MalTypeType )
+  MalTypeType% %allot                      ( s-a s-l MalTypeType )
+  dup 2swap rot                            ( MalTypeType s-a s-l MalTypeType )
+  MalTypeType-struct 2!                    ( MalTypeType ) \ store struct info
+  dup MalTypeType-methods     0   swap !   ( MalTypeType )
+  dup MalTypeType-method-keys nil swap !   ( MalTypeType )
+  dup MalTypeType-method-vals nil swap !   ( MalTypeType )
+  ;
+
+MalType% deftype* constant MalDefault
+
+\ nil type and instance to support extending protocols to it
+MalType% deftype* constant MalNil
+MalNil new constant mal-nil
 
 \ === protocol methods === /
 
@@ -271,41 +169,32 @@ MalList IPrintable extend
 end-extend
 )
 
-\ Examples of making new protocol methods (without a protocol to group them yet!)
-def-protocol-method pr-buf ( str-addr str-len this -- str-addr str-len )
-def-protocol-method conj ( obj this -- this )
+\ === Mal types and protocols === /
 
-: pr-str { obj }
-    new-str obj pr-buf ;
+MalType%
+  cell% field MalList/car
+  cell% field MalList/cdr
+deftype* constant MalList
+
+: MalList/conj { val coll -- list }
+    MalList new ( list )
+    val over MalList/car ! ( list )
+    coll over MalList/cdr ! ( list )
+    ;
+
+def-protocol-method conj ( obj this -- this )
 
 \ Examples of extending existing protocol methods to existing type
 MalDefault
-  extend pr-buf
-    { this }
-    s" #<MalObject" str-append a-space
-    this int>str str-append
-    s" >" str-append ;;
   extend conj   ( obj this -- this )
     swap drop ;;
 drop
 
 MalNil
-  extend pr-buf
-    drop s" nil" str-append ;;
   ' conj ' MalList/conj extend-method*
 drop
 
 MalList
-  extend pr-buf
-    -rot s" (" str-append ( list str-addr str-len )
-    rot dup MalList/cdr @ swap MalList/car @ 2swap rot pr-buf
-    begin ( list str-addr str-len )
-      2 pick mal-nil <>
-    while
-      a-space
-      rot dup MalList/cdr @ swap MalList/car @ 2swap rot pr-buf
-    repeat
-    s" )" str-append rot drop ;;
   ' conj ' MalList/conj extend-method*
 drop
 
@@ -314,20 +203,17 @@ MalType%
   cell% field MalInt/int
 deftype* constant MalInt
 
-MalInt
-  extend pr-buf
-    MalInt/int @ int>str str-append ;;
-drop
-
 : MalInt. { int -- mal-int }
     MalInt new dup MalInt/int int swap ! ;
 
-
-\ Run some protocol methods!
-
-mal-nil
-42 MalInt. mal-nil conj
-10 MalInt. mal-nil conj conj
-20 MalInt. swap conj
-23 MalInt. mal-nil conj conj conj
-pr-str s" (nil (20 (42) 10) 23)" str= -1 test=
+MalType%
+  cell% field MalSymbol/sym-addr
+  cell% field MalSymbol/sym-len
+  cell% field MalSymbol/meta
+deftype* constant MalSymbol
+
+: MalSymbol. { str-addr str-len -- mal-sym }
+    MalSymbol new { sym }
+    str-addr sym MalSymbol/sym-addr !
+    str-len  sym MalSymbol/sym-len  !
+    sym ;