forth: Added lists, ints, symbols for step 1

1 files changed, 63 insertions, 177 deletions

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 ;