From b745d1914925626c8e48fff3f95dcf440bb58755 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Wed, 4 Feb 2015 20:05:03 -0500
Subject: forth: Add basic protocol functionality

---
 forth/types.fs | 351 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 351 insertions(+)
 create mode 100644 forth/types.fs

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
new file mode 100644
index 0000000..3d76329
--- /dev/null
+++ b/forth/types.fs
@@ -0,0 +1,351 @@
+\ === tiny framework for inline tests === /
+: test=
+  2dup = if
+    2drop
+  else
+    cr ." assert failed on line " sourceline# .
+    swap cr ." | got " . cr ." | expected " . cr
+  endif ;
+
+\ === classic lisp list === /
+: cons { addr val -- new-list-address }
+  2 cells allocate throw
+  dup addr val rot 2! ;
+
+: cdr ( addr -- next-addr )
+  cell+ @ ;
+
+: int-pr ( num -- )
+  s>d <# #s #> type ;
+
+: prn ( list-address -- )
+  ." (" 2@ int-pr
+  begin
+    space 2@ int-pr
+    dup 0=
+  until
+  .\" )\n" ;
+
+0 1 cons 2 cons 3 cons 4 cons
+prn
+
+
+\ === mutable vector === /
+\ Singly-linked list, with an "object" pair that points to both ends.
+\ This allows fast append and fast iteration from beginning to end,
+\ like a vector.  ...but buys simplicity with mutability
+: new-mutvec ( -- mutvec-addr )
+  2 cells allocate throw
+  dup 0 0 rot 2! ;
+
+: mutvec-append { mutvec-addr value -- }
+  2 cells allocate throw    \ new pair
+  dup nil value rot 2!      \ put value in new pair
+  dup mutvec-addr @
+    ?dup 0= if mutvec-addr endif
+    cell+ !                 \ update old tail
+  mutvec-addr !             \ update object
+  ;
+
+new-mutvec
+dup 5 mutvec-append
+dup 4 mutvec-append
+dup 3 mutvec-append
+dup 2 mutvec-append
+cdr prn
+
+
+\ === 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 ;
+
+
+bl c,
+here constant space-str
+: a-space space-str 1 str-append ;
+
+new-str
+s" hello there" str-append a-space
+s" is this getting ...." str-append a-space
+s\" interesting yet?\n" str-append
+type
+
+\ A rewrite of the list-printer above, but now using string buffer:
+: int-pr-str2 ( num -- str-addr str-len )
+  s>d <# #s #> ;
+
+: pr-str2 ( strbuf str-len list-address -- )
+  -rot s" (" str-append rot
+  2@ 2swap rot int-pr-str2 str-append
+  begin
+    a-space
+    rot 2@ 2swap rot int-pr-str2 str-append
+    2 pick 0=
+  until
+  s" )" str-append rot drop ;
+
+new-str
+0 1 cons 2 cons 3 cons 4 cons
+pr-str2 type
+cr
+
+\ === 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
+
+\ Example and tests
+
+MalType%
+  cell% field obj-list/car
+  cell% field obj-list/cdr
+deftype* constant ObjList
+
+ObjList new
+ObjList new
+= 0 test=
+
+ObjList new dup obj-list/car 5 swap ! obj-list/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,
+\ and the methods array is maintained in parallel so that an index into
+\ one corresponds to an index in the other.
+
+\ Search a sorted array for key, returning the index of where it was
+\ found. If key is not in the array, return the index where it would
+\ be if added.
+: array-find { a-length a-addr key -- index found? }
+  0 a-length           ( start end )
+  begin
+    \ cr 2dup . .
+    2dup + 2 / dup     ( start end middle middle )
+    cells a-addr + @   ( start end middle mid-val )
+    dup key < if
+      drop rot         ( end middle start )
+      2dup = if
+        2drop dup      ( end end )
+      else
+        drop swap      ( middle end )
+      endif
+    else
+      key > if         ( start end middle )
+        swap drop      ( start middle )
+      else
+        -rot 2drop dup ( middle middle )
+      endif
+    endif
+  2dup = until
+  cells a-addr + @ key =
+  ;
+
+\ Create a new array, one cell in length, initialized the provided value
+: new-array { value -- array }
+  cell allocate throw value over ! ;
+
+\ Resize a heap-allocated array to be one cell longer, inserting value
+\ at idx, and shifting the tail of the array as necessary. Returns the
+\ (possibly new) array address
+: array-insert { old-array-length old-array idx value -- array }
+  old-array old-array-length 1+ cells resize throw
+  { a }
+  a idx cells +   dup cell+   old-array-length idx - cells   cmove>
+  value a idx cells + !
+  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=
+
+
+\ === protocol methods === /
+
+\ Used by protocol methods to find the appropriate implementation of
+\ themselves for the given object, and then execute that implementation.
+: execute-method { obj pxt -- }
+  obj mal-type @ dup MalTypeType-methods 2@ swap ( type methods method-keys )
+  dup 0= if \ No protocols extended to this type; check for a default
+    2drop drop MalDefault MalTypeType-methods 2@ swap
+  endif
+  dup 0= if ." No protocols extended to this type or MalDefault" 1 throw endif
+
+  pxt array-find ( type idx found? )
+  dup 0= if \ No implementation found for this method; check for a default
+    2drop MalDefault MalTypeType-methods 2@ swap
+    dup 0= if ." No implementation found for this method, and no protocols extended to MalDefault" 1 throw endif
+    pxt array-find ( type idx found? )
+  endif
+  0= if ." No implementation found" 1 throw endif
+
+  cells swap MalTypeType-method-vals @ + @ ( xt )
+  obj swap execute
+  ;
+
+\ Extend a type with a protocol method. This mutates the MalTypeType
+\ object that represents the MalType being extended.
+: extend-method* { type pxt ixt -- type }
+  type MalTypeType-methods 2@ swap ( methods method-keys )
+  dup 0= if \ no protocols extended to this type
+    2drop
+    1 type MalTypeType-methods !
+    pxt new-array type MalTypeType-method-keys !
+    ixt new-array type MalTypeType-method-vals !
+  else
+    pxt array-find { idx found? }
+    found? if \ overwrite
+      ." Warning: overwriting protocol method implementation"
+      type MalTypeType-method-vals @ idx cells + ixt !
+    else \ resize
+      type MalTypeType-methods dup @ 1+ dup rot ! ( new-count )
+      1- dup type MalTypeType-method-keys @ idx pxt array-insert ( old-count new-array )
+        type MalTypeType-method-keys ! ( old-count )
+      \ cr ." before: " ObjList MalTypeType-method-vals @ @ . cr
+      type MalTypeType-method-vals @ idx ixt array-insert ( new-array )
+        type MalTypeType-method-vals !
+      \ cr ." after: " ObjList MalTypeType-method-vals @ @ . cr
+    endif
+  endif
+  type
+  ;
+
+\ Examples of making new protocol methods (without a protocol to group them yet!)
+: pr-str [ latestxt ] literal execute-method ;
+: conj   [ latestxt ] literal execute-method ;
+
+\ Examples of extending existing protocol methods to existing type
+MalDefault ' pr-str :noname s" #<MalObject>" ; extend-method*
+ObjList ' pr-str :noname drop s" #<ObjList>" ; extend-method*
+ObjList ' conj :noname ." not yet done" ; extend-method*
+
+\ Run some protocol methods!
+ObjList new pr-str type
+ObjList new conj
+
+(
+  method-count 1+ to method-count
+
+protocol IPrintable
+  method% pr-str
+end-protocol
+)
+
+(
+ObjList IPrintable extend
+
+  ' pr-str :noname drop s" <unprintable>" ; extend-method*
+
+  extend-method pr-str
+    drop s" <unprintable>" ;
+end-extend
+)
+
+\ new-obj
+
+\ new-instance
+
+
+\ maybe useful for debugging?
+: p dup . ;
+: @p dup @ dup . ;
+
+(
+
+create buff 128 allot
+
+." user> "
+
+buff 128 stdin read-line throw
+
+buff c@ .
+buff 5 + c@ .
+
+S" Hello" dup . type
+
+
+)
+
+
+cr
+bye
+." Done loading" cr
-- 
cgit v1.2.3


From 14b846ffeb0a785c4918e4a3850ee229fcf1879d Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Wed, 4 Feb 2015 21:44:37 -0500
Subject: forth: protocols and some pr-str working

---
 forth/types.fs | 213 +++++++++++++++++++++++++++------------------------------
 1 file changed, 99 insertions(+), 114 deletions(-)

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
index 3d76329..2f97fa5 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -7,52 +7,12 @@
     swap cr ." | got " . cr ." | expected " . cr
   endif ;
 
-\ === classic lisp list === /
-: cons { addr val -- new-list-address }
-  2 cells allocate throw
-  dup addr val rot 2! ;
-
-: cdr ( addr -- next-addr )
-  cell+ @ ;
-
-: int-pr ( num -- )
-  s>d <# #s #> type ;
-
-: prn ( list-address -- )
-  ." (" 2@ int-pr
-  begin
-    space 2@ int-pr
-    dup 0=
-  until
-  .\" )\n" ;
-
-0 1 cons 2 cons 3 cons 4 cons
-prn
-
-
-\ === mutable vector === /
-\ Singly-linked list, with an "object" pair that points to both ends.
-\ This allows fast append and fast iteration from beginning to end,
-\ like a vector.  ...but buys simplicity with mutability
-: new-mutvec ( -- mutvec-addr )
-  2 cells allocate throw
-  dup 0 0 rot 2! ;
-
-: mutvec-append { mutvec-addr value -- }
-  2 cells allocate throw    \ new pair
-  dup nil value rot 2!      \ put value in new pair
-  dup mutvec-addr @
-    ?dup 0= if mutvec-addr endif
-    cell+ !                 \ update old tail
-  mutvec-addr !             \ update object
-  ;
-
-new-mutvec
-dup 5 mutvec-append
-dup 4 mutvec-append
-dup 3 mutvec-append
-dup 2 mutvec-append
-cdr prn
+: safe-type ( str-addr str-len -- )
+    dup 256 > if
+        drop 256 type ." ...<lots more>" type
+    else
+        type
+    endif ;
 
 
 \ === mutable string buffer === /
@@ -85,35 +45,14 @@ cdr prn
   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 ;
 
-new-str
-s" hello there" str-append a-space
-s" is this getting ...." str-append a-space
-s\" interesting yet?\n" str-append
-type
-
-\ A rewrite of the list-printer above, but now using string buffer:
-: int-pr-str2 ( num -- str-addr str-len )
+: int>str ( num -- str-addr str-len )
   s>d <# #s #> ;
 
-: pr-str2 ( strbuf str-len list-address -- )
-  -rot s" (" str-append rot
-  2@ 2swap rot int-pr-str2 str-append
-  begin
-    a-space
-    rot 2@ 2swap rot int-pr-str2 str-append
-    2 pick 0=
-  until
-  s" )" str-append rot drop ;
-
-new-str
-0 1 cons 2 cons 3 cons 4 cons
-pr-str2 type
-cr
 
 \ === deftype* -- protocol-enabled structs === /
 \ Each type has MalTypeType% struct allocated on the stack, with
@@ -151,18 +90,29 @@ end-struct 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 obj-list/car
-  cell% field obj-list/cdr
-deftype* constant ObjList
-
-ObjList new
-ObjList new
+  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=
 
-ObjList new dup obj-list/car 5 swap ! obj-list/car @   5 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
@@ -252,7 +202,7 @@ dup 5 cells + @  20 test=
 
   pxt array-find ( type idx found? )
   dup 0= if \ No implementation found for this method; check for a default
-    2drop MalDefault MalTypeType-methods 2@ swap
+    2drop drop MalDefault dup MalTypeType-methods 2@ swap
     dup 0= if ." No implementation found for this method, and no protocols extended to MalDefault" 1 throw endif
     pxt array-find ( type idx found? )
   endif
@@ -280,72 +230,107 @@ dup 5 cells + @  20 test=
       type MalTypeType-methods dup @ 1+ dup rot ! ( new-count )
       1- dup type MalTypeType-method-keys @ idx pxt array-insert ( old-count new-array )
         type MalTypeType-method-keys ! ( old-count )
-      \ cr ." before: " ObjList MalTypeType-method-vals @ @ . cr
+      \ cr ." before: " MalList MalTypeType-method-vals @ @ . cr
       type MalTypeType-method-vals @ idx ixt array-insert ( new-array )
         type MalTypeType-method-vals !
-      \ cr ." after: " ObjList MalTypeType-method-vals @ @ . cr
+      \ cr ." after: " MalList MalTypeType-method-vals @ @ . cr
     endif
   endif
   type
   ;
 
-\ Examples of making new protocol methods (without a protocol to group them yet!)
-: pr-str [ latestxt ] literal execute-method ;
-: conj   [ latestxt ] literal execute-method ;
 
-\ Examples of extending existing protocol methods to existing type
-MalDefault ' pr-str :noname s" #<MalObject>" ; extend-method*
-ObjList ' pr-str :noname drop s" #<ObjList>" ; extend-method*
-ObjList ' conj :noname ." not yet done" ; extend-method*
+\ def-protocol-method pr-str   ...can be written:
+\ : pr-str ( obj -- str ) [ latestxt ] literal execute-method ;
+: def-protocol-method ( "name" -- )
+    create latestxt ,
+  does> ( ??? obj xt-ref -- ??? )
+    @ execute-method ;
 
-\ Run some protocol methods!
-ObjList new pr-str type
-ObjList new conj
+: extend ( type -- type pxt <noname...>)
+    parse-name find-name name>int ( type pxt )
+    :noname
+    ;
 
-(
-  method-count 1+ to method-count
+: ;; ( type pxt <noname...> -- type )
+    [compile] ; ( type pxt ixt )
+    extend-method*
+    ; immediate
 
+(
+\ These whole-protocol names are only needed for 'satisfies?':
 protocol IPrintable
-  method% pr-str
+  def-protocol-method pr-str
 end-protocol
-)
-
-(
-ObjList IPrintable extend
 
+MalList IPrintable extend
   ' pr-str :noname drop s" <unprintable>" ; extend-method*
 
   extend-method pr-str
-    drop s" <unprintable>" ;
+    drop s" <unprintable>" ;;
 end-extend
 )
 
-\ new-obj
-
-\ new-instance
-
+\ 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 )
 
-\ maybe useful for debugging?
-: p dup . ;
-: @p dup @ dup . ;
+: 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 ;;
+  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
 
-create buff 128 allot
 
-." user> "
+MalType%
+  cell% field MalInt/int
+deftype* constant MalInt
 
-buff 128 stdin read-line throw
+MalInt
+  extend pr-buf
+    MalInt/int @ int>str str-append ;;
+drop
 
-buff c@ .
-buff 5 + c@ .
+: MalInt. { int -- mal-int }
+    MalInt new dup MalInt/int int swap ! ;
 
-S" Hello" dup . type
 
+\ 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 safe-type cr
 
-cr
 bye
-." Done loading" cr
-- 
cgit v1.2.3


From ccc7d9d199c56473997b40f49c6bfc79d9799fd2 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Thu, 5 Feb 2015 18:47:32 -0500
Subject: forth: Add step 0

---
 forth/types.fs | 5 +----
 1 file changed, 1 insertion(+), 4 deletions(-)

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
index 2f97fa5..460c3aa 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -330,7 +330,4 @@ mal-nil
 10 MalInt. mal-nil conj conj
 20 MalInt. swap conj
 23 MalInt. mal-nil conj conj conj
-
-pr-str safe-type cr
-
-bye
+pr-str s" (nil (20 (42) 10) 23)" str= -1 test=
-- 
cgit v1.2.3


From 59038a10f0e3ad65675cafdb149eb61405e334d3 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Fri, 6 Feb 2015 00:38:34 -0500
Subject: forth: Added lists, ints, symbols for step 1

---
 forth/types.fs | 240 +++++++++++++++------------------------------------------
 1 file changed, 63 insertions(+), 177 deletions(-)

(limited to 'forth/types.fs')

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 ;
-- 
cgit v1.2.3


From 50e417ffe32c238189e61c9701696602d40bb7f3 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Fri, 6 Feb 2015 02:38:58 -0500
Subject: forth: Add string printing

---
 forth/types.fs | 15 +++++++++++++--
 1 file changed, 13 insertions(+), 2 deletions(-)

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
index 2b74576..75996f8 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -22,7 +22,7 @@
       endif
     else
       key > if         ( start end middle )
-        swap drop      ( start middle )
+        nip            ( start middle )
       else
         -rot 2drop dup ( middle middle )
       endif
@@ -187,7 +187,7 @@ def-protocol-method conj ( obj this -- this )
 \ Examples of extending existing protocol methods to existing type
 MalDefault
   extend conj   ( obj this -- this )
-    swap drop ;;
+    nip ;;
 drop
 
 MalNil
@@ -217,3 +217,14 @@ deftype* constant MalSymbol
     str-addr sym MalSymbol/sym-addr !
     str-len  sym MalSymbol/sym-len  !
     sym ;
+
+MalType%
+  cell% field MalString/str-addr
+  cell% field MalString/str-len
+deftype* constant MalString
+
+: MalString. { str-addr str-len -- mal-str }
+    MalString new { str }
+    str-addr str MalString/str-addr !
+    str-len  str MalString/str-len  !
+    str ;
-- 
cgit v1.2.3


From 168fb5dc56fee6653816ee8236259940e575c7ec Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Fri, 6 Feb 2015 23:58:41 -0500
Subject: forth: Add step 1, but not maps

---
 forth/types.fs | 4 ++++
 1 file changed, 4 insertions(+)

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
index 75996f8..7f6b6ea 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -184,6 +184,10 @@ deftype* constant MalList
 
 def-protocol-method conj ( obj this -- this )
 
+MalType%
+  cell% field MalVector/list
+deftype* constant MalVector
+
 \ Examples of extending existing protocol methods to existing type
 MalDefault
   extend conj   ( obj this -- this )
-- 
cgit v1.2.3


From 2e78e94eb894e511e583db03286a3c13b9ecc780 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Sat, 7 Feb 2015 10:01:31 -0500
Subject: forth: Finished step 1

---
 forth/types.fs | 4 ++++
 1 file changed, 4 insertions(+)

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
index 7f6b6ea..2933448 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -188,6 +188,10 @@ MalType%
   cell% field MalVector/list
 deftype* constant MalVector
 
+MalType%
+  cell% field MalMap/list
+deftype* constant MalMap
+
 \ Examples of extending existing protocol methods to existing type
 MalDefault
   extend conj   ( obj this -- this )
-- 
cgit v1.2.3


From 9da223a35a176d94fbb75cbcc1000871ff5aff0b Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Thu, 12 Feb 2015 19:27:00 -0500
Subject: forth: Add step 2

---
 forth/types.fs | 183 ++++++++++++++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 174 insertions(+), 9 deletions(-)

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
index 2933448..2c4d178 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -65,6 +65,8 @@ struct
   cell% field MalTypeType-methods
   cell% field MalTypeType-method-keys
   cell% field MalTypeType-method-vals
+  cell% field MalTypeType-name-addr
+  cell% field MalTypeType-name-len
 end-struct MalTypeType%
 
 : new ( MalTypeType -- obj )
@@ -79,12 +81,31 @@ end-struct MalTypeType%
   dup MalTypeType-methods     0   swap !   ( MalTypeType )
   dup MalTypeType-method-keys nil swap !   ( MalTypeType )
   dup MalTypeType-method-vals nil swap !   ( MalTypeType )
+  dup MalTypeType-name-len    0   swap !   ( MalTypeType )
   ;
 
-MalType% deftype* constant MalDefault
+: deftype ( struct-align struct-len R:type-name -- )
+    parse-name { orig-name-addr name-len }
+    \ parse-name uses temporary space, so copy into dictionary stack:
+    here { name-addr } name-len allot
+    orig-name-addr name-addr name-len cmove
+
+    \ allot and initialize type structure
+    deftype* { mt }
+    name-addr mt MalTypeType-name-addr !
+    name-len  mt MalTypeType-name-len  !
+    \ ." Defining " mt MalTypeType-name-addr @ mt MalTypeType-name-len @ type cr
+    mt name-addr name-len nextname 1 0 const-does> ;
+
+: type-name ( mal-type )
+    dup  MalTypeType-name-addr @ ( mal-type name-addr )
+    swap MalTypeType-name-len @ ( name-addr name-len )
+    ;
+
+MalType% deftype MalDefault
 
 \ nil type and instance to support extending protocols to it
-MalType% deftype* constant MalNil
+MalType% deftype MalNil
 MalNil new constant mal-nil
 
 \ === protocol methods === /
@@ -104,7 +125,15 @@ MalNil new constant mal-nil
     dup 0= if ." No implementation found for this method, and no protocols extended to MalDefault" 1 throw endif
     pxt array-find ( type idx found? )
   endif
-  0= if ." No implementation found" 1 throw endif
+  0= if ( type idx )
+      2drop
+      ." No protocol fn '"
+      pxt >name name>string type
+      ." ' extended to type '"
+      obj mal-type @ type-name type
+      ." '"
+      1 throw
+  endif
 
   cells swap MalTypeType-method-vals @ + @ ( xt )
   obj swap execute
@@ -174,7 +203,7 @@ end-extend
 MalType%
   cell% field MalList/car
   cell% field MalList/cdr
-deftype* constant MalList
+deftype MalList
 
 : MalList/conj { val coll -- list }
     MalList new ( list )
@@ -182,24 +211,77 @@ deftype* constant MalList
     coll over MalList/cdr ! ( list )
     ;
 
+MalType%
+  cell% field MalArray/count
+  cell% field MalArray/start
+deftype MalArray
+
+: here>MalArray ( old-here -- mal-array )
+    here over - { bytes } ( old-here )
+    MalArray new bytes ( old-here mal-array bytes )
+    allocate throw dup { target } over MalArray/start ! ( old-here mal-array )
+    bytes cell / over MalArray/count ! ( old-here mal-array )
+    swap target bytes cmove ( mal-array )
+    0 bytes - allot \ pop array contents from dictionary stack
+    ;
+
 def-protocol-method conj ( obj this -- this )
+def-protocol-method assoc ( k v this -- this )
+def-protocol-method get ( not-found k this -- value )
+def-protocol-method mal= ( a b -- bool )
+def-protocol-method as-native ( obj --  )
+def-protocol-method invoke ( argv argc mal-fn -- ... )
 
 MalType%
   cell% field MalVector/list
-deftype* constant MalVector
+deftype MalVector
 
 MalType%
   cell% field MalMap/list
-deftype* constant MalMap
+deftype MalMap
+
+MalMap new mal-nil over MalMap/list ! constant MalMap/Empty
+
+MalMap
+  extend conj ( kv map -- map )
+    MalMap/list @ \ get list
+    over MalList/cdr @ MalList/car @ conj \ add value
+    swap MalList/car @ conj \ add key
+    MalMap new MalMap/list ! \ put back in map
+    ;;
+  extend assoc ( k v map -- map )
+    MalMap/list @ \ get list
+    conj conj
+    MalMap new dup -rot MalMap/list ! \ put back in map
+    ;;
+  extend get ( not-found k map -- value )
+    -rot { not-found k }
+    MalMap/list @ \ get list
+    begin
+        dup MalList/cdr @
+        swap MalList/car @ k mal= if
+            MalList/car @ -1 \ found it
+        else
+            MalList/cdr @
+            dup mal-nil = if
+                not-found -1
+            else
+                0
+            endif
+        endif
+    until ;;
+drop
 
 \ Examples of extending existing protocol methods to existing type
 MalDefault
   extend conj   ( obj this -- this )
     nip ;;
+  extend as-native ;; ( obj -- obj )
 drop
 
 MalNil
   ' conj ' MalList/conj extend-method*
+  extend as-native drop 0 ;;
 drop
 
 MalList
@@ -209,30 +291,113 @@ drop
 
 MalType%
   cell% field MalInt/int
-deftype* constant MalInt
+deftype MalInt
 
 : MalInt. { int -- mal-int }
     MalInt new dup MalInt/int int swap ! ;
 
+MalInt
+  extend as-native ( mal-int -- int )
+    MalInt/int @ ;;
+drop
+
 MalType%
   cell% field MalSymbol/sym-addr
   cell% field MalSymbol/sym-len
   cell% field MalSymbol/meta
-deftype* constant MalSymbol
+deftype MalSymbol
 
 : MalSymbol. { str-addr str-len -- mal-sym }
     MalSymbol new { sym }
     str-addr sym MalSymbol/sym-addr !
     str-len  sym MalSymbol/sym-len  !
+    MalMap/Empty sym MalSymbol/meta  !
     sym ;
 
+: unpack-sym ( mal-string -- addr len )
+    dup MalSymbol/sym-addr @
+    swap MalSymbol/sym-len @ ;
+
+MalSymbol
+  extend mal= ( other this -- bool )
+    over mal-type @ MalSymbol = if
+        unpack-sym rot unpack-sym str=
+    else
+        2drop 0
+    endif ;;
+  ' as-native ' unpack-sym extend-method*
+drop
+
+MalType%
+  cell% field MalKeyword/str-addr
+  cell% field MalKeyword/str-len
+deftype MalKeyword
+
+: unpack-keyword ( mal-keyword -- addr len )
+    dup MalKeyword/str-addr @
+    swap MalKeyword/str-len @ ;
+
+MalKeyword
+  extend mal= ( other this -- bool )
+    over mal-type @ MalKeyword = if
+        unpack-keyword rot unpack-keyword str=
+    else
+        2drop 0
+    endif ;;
+  ' as-native ' unpack-keyword extend-method*
+  extend invoke { argv argc kw -- val }
+    argc 1 > if argv cell+ @ else mal-nil endif \ not-found
+    kw \ key
+    argv @ \ map
+    get ;;
+drop
+
+: MalKeyword. { str-addr str-len -- mal-keyword }
+    MalKeyword new { kw }
+    str-addr kw MalKeyword/str-addr !
+    str-len  kw MalKeyword/str-len  !
+    kw ;
+
 MalType%
   cell% field MalString/str-addr
   cell% field MalString/str-len
-deftype* constant MalString
+deftype MalString
 
 : MalString. { str-addr str-len -- mal-str }
     MalString new { str }
     str-addr str MalString/str-addr !
     str-len  str MalString/str-len  !
     str ;
+
+: unpack-str ( mal-string -- addr len )
+    dup MalString/str-addr @
+    swap MalString/str-len @ ;
+
+MalString
+  extend mal= ( other this -- bool )
+    over mal-type @ MalString = if
+        unpack-str rot unpack-str str=
+    else
+        2drop 0
+    endif ;;
+  ' as-native ' unpack-str extend-method*
+drop
+
+
+MalType%
+  cell% field MalFn/xt
+  cell% field MalFn/meta
+deftype MalFn
+
+: MalFn. { xt -- mal-fn }
+    MalFn new { mal-fn }
+    xt mal-fn MalFn/xt !
+    MalMap/Empty mal-fn MalFn/meta  !
+    mal-fn ;
+
+MalFn
+  extend invoke ( ... mal-fn -- ... )
+    MalFn/xt @ execute ;;
+  extend as-native
+    MalFn/xt @ ;;
+drop
-- 
cgit v1.2.3


From 69972a8399efe4abb8567526e90262e131f90d26 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Sat, 14 Feb 2015 13:40:07 -0500
Subject: forth: Add step 3

---
 forth/types.fs | 93 ++++++++++++++++++++++++++++++++++++++++------------------
 1 file changed, 65 insertions(+), 28 deletions(-)

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
index 2c4d178..a8268a3 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -200,6 +200,20 @@ end-extend
 
 \ === Mal types and protocols === /
 
+def-protocol-method conj ( obj this -- this )
+def-protocol-method assoc ( k v this -- this )
+def-protocol-method get ( not-found k this -- value )
+def-protocol-method mal= ( a b -- bool )
+def-protocol-method as-native ( obj --  )
+def-protocol-method to-array ( obj -- mal-array )
+
+: m= ( a b -- bool )
+    2dup = if
+        2drop -1
+    else
+        mal=
+    endif ;
+
 MalType%
   cell% field MalList/car
   cell% field MalList/cdr
@@ -225,48 +239,63 @@ deftype MalArray
     0 bytes - allot \ pop array contents from dictionary stack
     ;
 
-def-protocol-method conj ( obj this -- this )
-def-protocol-method assoc ( k v this -- this )
-def-protocol-method get ( not-found k this -- value )
-def-protocol-method mal= ( a b -- bool )
-def-protocol-method as-native ( obj --  )
-def-protocol-method invoke ( argv argc mal-fn -- ... )
+MalArray
+  extend to-array ;;
+  extend conj { elem old-ary -- ary }
+    old-ary MalArray/count @ 1+ { new-count }
+    new-count cells allocate throw { new-start }
+    elem new-start !
+    new-count 1 > if
+      old-ary MalArray/start @   new-start cell+   new-count 1- cells  cmove
+    endif
+
+    MalArray new
+    new-count over MalArray/count !
+    new-start over MalArray/start ! ;;
+drop
+
+MalArray new 0 over MalArray/count ! constant MalArray/Empty
 
 MalType%
   cell% field MalVector/list
 deftype MalVector
 
+MalVector
+  extend to-array
+    MalVector/list @ to-array ;;
+drop
+
 MalType%
   cell% field MalMap/list
 deftype MalMap
 
-MalMap new mal-nil over MalMap/list ! constant MalMap/Empty
+MalMap new MalArray/Empty over MalMap/list ! constant MalMap/Empty
 
 MalMap
   extend conj ( kv map -- map )
     MalMap/list @ \ get list
-    over MalList/cdr @ MalList/car @ conj \ add value
-    swap MalList/car @ conj \ add key
-    MalMap new MalMap/list ! \ put back in map
+    over MalArray/start @ cell+ @ swap conj \ add value
+    swap MalArray/start @ @ swap conj \ add key
+    MalMap new dup -rot MalMap/list ! \ put back in map
     ;;
   extend assoc ( k v map -- map )
     MalMap/list @ \ get list
-    conj conj
+    conj conj 
     MalMap new dup -rot MalMap/list ! \ put back in map
     ;;
-  extend get ( not-found k map -- value )
-    -rot { not-found k }
-    MalMap/list @ \ get list
+  extend get { not-found k map -- value }
+    map MalMap/list @
+    dup MalArray/start @ { start }
+    MalArray/count @ { count }
+    0
     begin
-        dup MalList/cdr @
-        swap MalList/car @ k mal= if
-            MalList/car @ -1 \ found it
+        dup count >= if
+            drop not-found -1
         else
-            MalList/cdr @
-            dup mal-nil = if
-                not-found -1
+            start over cells + @ k m= if
+                start swap cells + cell+ @ -1 \ found it ( value -1 )
             else
-                0
+                2 + 0
             endif
         endif
     until ;;
@@ -297,6 +326,13 @@ deftype MalInt
     MalInt new dup MalInt/int int swap ! ;
 
 MalInt
+  extend mal= ( other this -- bool )
+    over mal-type @ MalInt = if
+        MalInt/int @ swap MalInt/int @ =
+    else
+        2drop 0
+    endif ;;
+
   extend as-native ( mal-int -- int )
     MalInt/int @ ;;
 drop
@@ -345,11 +381,6 @@ MalKeyword
         2drop 0
     endif ;;
   ' as-native ' unpack-keyword extend-method*
-  extend invoke { argv argc kw -- val }
-    argc 1 > if argv cell+ @ else mal-nil endif \ not-found
-    kw \ key
-    argv @ \ map
-    get ;;
 drop
 
 : MalKeyword. { str-addr str-len -- mal-keyword }
@@ -396,8 +427,14 @@ deftype MalFn
     mal-fn ;
 
 MalFn
-  extend invoke ( ... mal-fn -- ... )
-    MalFn/xt @ execute ;;
   extend as-native
     MalFn/xt @ ;;
 drop
+
+
+MalType%
+  cell% field SpecialOp/xt
+deftype SpecialOp
+
+: SpecialOp.
+    SpecialOp new swap over SpecialOp/xt ! ;
-- 
cgit v1.2.3


From c05d35e8dd1ebbc371d7c9239d788ddf844eae31 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Sat, 14 Feb 2015 15:18:18 -0500
Subject: forth: Get rid of car/cdr style lists

Rename MalArray to MalList
---
 forth/types.fs | 87 +++++++++++++++++++++++++++-------------------------------
 1 file changed, 41 insertions(+), 46 deletions(-)

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
index a8268a3..305ff31 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -108,21 +108,32 @@ MalType% deftype MalDefault
 MalType% deftype MalNil
 MalNil new constant mal-nil
 
+: not-object? ( obj -- bool )
+    dup 7 and 0 <> if
+        drop -1
+    else
+        1000000 <
+    endif ;
+
 \ === protocol methods === /
 
 \ Used by protocol methods to find the appropriate implementation of
 \ themselves for the given object, and then execute that implementation.
 : execute-method { obj pxt -- }
+  obj not-object? if
+      ." Refusing to invoke protocol fn '"
+      pxt >name name>string type
+      ." ' on non-object: " obj .
+      1 throw
+  endif
   obj mal-type @ dup MalTypeType-methods 2@ swap ( type methods method-keys )
   dup 0= if \ No protocols extended to this type; check for a default
     2drop drop MalDefault MalTypeType-methods 2@ swap
   endif
-  dup 0= if ." No protocols extended to this type or MalDefault" 1 throw endif
 
   pxt array-find ( type idx found? )
   dup 0= if \ No implementation found for this method; check for a default
     2drop drop MalDefault dup MalTypeType-methods 2@ swap
-    dup 0= if ." No implementation found for this method, and no protocols extended to MalDefault" 1 throw endif
     pxt array-find ( type idx found? )
   endif
   0= if ( type idx )
@@ -157,10 +168,8 @@ MalNil new constant mal-nil
       type MalTypeType-methods dup @ 1+ dup rot ! ( new-count )
       1- dup type MalTypeType-method-keys @ idx pxt array-insert ( old-count new-array )
         type MalTypeType-method-keys ! ( old-count )
-      \ cr ." before: " MalList MalTypeType-method-vals @ @ . cr
       type MalTypeType-method-vals @ idx ixt array-insert ( new-array )
         type MalTypeType-method-vals !
-      \ cr ." after: " MalList MalTypeType-method-vals @ @ . cr
     endif
   endif
   type
@@ -205,7 +214,7 @@ def-protocol-method assoc ( k v this -- this )
 def-protocol-method get ( not-found k this -- value )
 def-protocol-method mal= ( a b -- bool )
 def-protocol-method as-native ( obj --  )
-def-protocol-method to-array ( obj -- mal-array )
+def-protocol-method to-list ( obj -- mal-list )
 
 : m= ( a b -- bool )
     2dup = if
@@ -215,78 +224,67 @@ def-protocol-method to-array ( obj -- mal-array )
     endif ;
 
 MalType%
-  cell% field MalList/car
-  cell% field MalList/cdr
+  cell% field MalList/count
+  cell% field MalList/start
 deftype MalList
 
-: MalList/conj { val coll -- list }
-    MalList new ( list )
-    val over MalList/car ! ( list )
-    coll over MalList/cdr ! ( list )
-    ;
-
-MalType%
-  cell% field MalArray/count
-  cell% field MalArray/start
-deftype MalArray
-
-: here>MalArray ( old-here -- mal-array )
+: here>MalList ( old-here -- mal-list )
     here over - { bytes } ( old-here )
-    MalArray new bytes ( old-here mal-array bytes )
-    allocate throw dup { target } over MalArray/start ! ( old-here mal-array )
-    bytes cell / over MalArray/count ! ( old-here mal-array )
-    swap target bytes cmove ( mal-array )
-    0 bytes - allot \ pop array contents from dictionary stack
+    MalList new bytes ( old-here mal-list bytes )
+    allocate throw dup { target } over MalList/start ! ( old-here mal-list )
+    bytes cell / over MalList/count ! ( old-here mal-list )
+    swap target bytes cmove ( mal-list )
+    0 bytes - allot \ pop list contents from dictionary stack
     ;
 
-MalArray
-  extend to-array ;;
-  extend conj { elem old-ary -- ary }
-    old-ary MalArray/count @ 1+ { new-count }
+MalList
+  extend to-list ;;
+  extend conj { elem old-list -- list }
+    old-list MalList/count @ 1+ { new-count }
     new-count cells allocate throw { new-start }
     elem new-start !
     new-count 1 > if
-      old-ary MalArray/start @   new-start cell+   new-count 1- cells  cmove
+      old-list MalList/start @   new-start cell+   new-count 1- cells  cmove
     endif
 
-    MalArray new
-    new-count over MalArray/count !
-    new-start over MalArray/start ! ;;
+    MalList new
+    new-count over MalList/count !
+    new-start over MalList/start ! ;;
 drop
 
-MalArray new 0 over MalArray/count ! constant MalArray/Empty
+MalList new 0 over MalList/count ! constant MalList/Empty
 
 MalType%
   cell% field MalVector/list
 deftype MalVector
 
 MalVector
-  extend to-array
-    MalVector/list @ to-array ;;
+  extend to-list
+    MalVector/list @ to-list ;;
 drop
 
 MalType%
   cell% field MalMap/list
 deftype MalMap
 
-MalMap new MalArray/Empty over MalMap/list ! constant MalMap/Empty
+MalMap new MalList/Empty over MalMap/list ! constant MalMap/Empty
 
 MalMap
   extend conj ( kv map -- map )
     MalMap/list @ \ get list
-    over MalArray/start @ cell+ @ swap conj \ add value
-    swap MalArray/start @ @ swap conj \ add key
+    over MalList/start @ cell+ @ swap conj \ add value
+    swap MalList/start @ @ swap conj \ add key
     MalMap new dup -rot MalMap/list ! \ put back in map
     ;;
   extend assoc ( k v map -- map )
     MalMap/list @ \ get list
-    conj conj 
+    conj conj
     MalMap new dup -rot MalMap/list ! \ put back in map
     ;;
   extend get { not-found k map -- value }
     map MalMap/list @
-    dup MalArray/start @ { start }
-    MalArray/count @ { count }
+    dup MalList/start @ { start }
+    MalList/count @ { count }
     0
     begin
         dup count >= if
@@ -309,14 +307,11 @@ MalDefault
 drop
 
 MalNil
-  ' conj ' MalList/conj extend-method*
+  extend conj ( item nil -- mal-list )
+    drop MalList/Empty conj ;;
   extend as-native drop 0 ;;
 drop
 
-MalList
-  ' conj ' MalList/conj extend-method*
-drop
-
 
 MalType%
   cell% field MalInt/int
-- 
cgit v1.2.3


From 79feb89f9c75d30e79b9ef13fa40d2f8e22f4b9b Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Sat, 14 Feb 2015 16:08:17 -0500
Subject: forth: Add defspecial for Mal special ops

---
 forth/types.fs | 19 ++++++++++++-------
 1 file changed, 12 insertions(+), 7 deletions(-)

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
index 305ff31..a8dd2da 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -84,11 +84,15 @@ end-struct MalTypeType%
   dup MalTypeType-name-len    0   swap !   ( MalTypeType )
   ;
 
+\ parse-name uses temporary space, so copy into dictionary stack:
+: parse-allot-name { -- new-str-addr str-len }
+    parse-name { str-addr str-len }
+    here { new-str-addr } str-len allot
+    str-addr new-str-addr str-len cmove
+    new-str-addr str-len ;
+
 : deftype ( struct-align struct-len R:type-name -- )
-    parse-name { orig-name-addr name-len }
-    \ parse-name uses temporary space, so copy into dictionary stack:
-    here { name-addr } name-len allot
-    orig-name-addr name-addr name-len cmove
+    parse-allot-name { name-addr name-len }
 
     \ allot and initialize type structure
     deftype* { mt }
@@ -183,14 +187,15 @@ MalNil new constant mal-nil
   does> ( ??? obj xt-ref -- ??? )
     @ execute-method ;
 
-: extend ( type -- type pxt <noname...>)
+: extend ( type -- type pxt install-xt <noname...>)
     parse-name find-name name>int ( type pxt )
+    ['] extend-method*
     :noname
     ;
 
 : ;; ( type pxt <noname...> -- type )
-    [compile] ; ( type pxt ixt )
-    extend-method*
+    [compile] ; ( type pxt install-xt ixt )
+    swap execute
     ; immediate
 
 (
-- 
cgit v1.2.3


From 60801ed68d5b2c6630c83883de150ccce98767f9 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Sun, 15 Feb 2015 13:33:44 -0500
Subject: forth: Add step 4, but not varargs

---
 forth/types.fs | 91 ++++++++++++++++++++++++++++++++++++++++++++--------------
 1 file changed, 69 insertions(+), 22 deletions(-)

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
index a8dd2da..5eb546f 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -109,8 +109,12 @@ end-struct MalTypeType%
 MalType% deftype MalDefault
 
 \ nil type and instance to support extending protocols to it
-MalType% deftype MalNil
-MalNil new constant mal-nil
+MalType% deftype MalNil   MalNil   new constant mal-nil
+MalType% deftype MalTrue  MalTrue  new constant mal-true
+MalType% deftype MalFalse MalFalse new constant mal-false
+
+: mal-bool
+    0= if mal-false else mal-true endif ;
 
 : not-object? ( obj -- bool )
     dup 7 and 0 <> if
@@ -219,7 +223,10 @@ def-protocol-method assoc ( k v this -- this )
 def-protocol-method get ( not-found k this -- value )
 def-protocol-method mal= ( a b -- bool )
 def-protocol-method as-native ( obj --  )
+
 def-protocol-method to-list ( obj -- mal-list )
+def-protocol-method empty? ( obj -- mal-bool )
+def-protocol-method mal-count ( obj -- mal-int )
 
 : m= ( a b -- bool )
     2dup = if
@@ -228,6 +235,27 @@ def-protocol-method to-list ( obj -- mal-list )
         mal=
     endif ;
 
+
+MalType%
+  cell% field MalInt/int
+deftype MalInt
+
+: MalInt. { int -- mal-int }
+    MalInt new dup MalInt/int int swap ! ;
+
+MalInt
+  extend mal= ( other this -- bool )
+    over mal-type @ MalInt = if
+        MalInt/int @ swap MalInt/int @ =
+    else
+        2drop 0
+    endif ;;
+
+  extend as-native ( mal-int -- int )
+    MalInt/int @ ;;
+drop
+
+
 MalType%
   cell% field MalList/count
   cell% field MalList/start
@@ -255,6 +283,26 @@ MalList
     MalList new
     new-count over MalList/count !
     new-start over MalList/start ! ;;
+  extend empty? MalList/count @ 0= mal-bool ;;
+  extend mal-count MalList/count @ MalInt. ;;
+  extend mal=
+    swap to-list dup 0= if
+        nip
+    else
+        2dup MalList/count @ swap MalList/count @ over = if ( list-a list-b count )
+            -rot MalList/start @ swap MalList/start @ { start-b start-a }
+            -1 swap ( return-val count )
+            0 ?do
+                start-a i cells + @
+                start-b i cells + @
+                m= if else
+                    drop 0 leave
+                endif
+            loop
+        else
+            drop 2drop 0
+        endif
+    endif ;;
 drop
 
 MalList new 0 over MalList/count ! constant MalList/Empty
@@ -266,6 +314,12 @@ deftype MalVector
 MalVector
   extend to-list
     MalVector/list @ to-list ;;
+  extend empty?
+    MalVector/list @
+    MalList/count @ 0= mal-bool ;;
+  extend mal-count
+    MalVector/list @
+    MalList/count @ MalInt. ;;
 drop
 
 MalType%
@@ -302,6 +356,12 @@ MalMap
             endif
         endif
     until ;;
+  extend empty?
+    MalMap/list @
+    MalList/count @ 0= mal-bool ;;
+  extend mal-count
+    MalMap/list @
+    MalList/count @ 2 / MalInt. ;;
 drop
 
 \ Examples of extending existing protocol methods to existing type
@@ -309,32 +369,16 @@ MalDefault
   extend conj   ( obj this -- this )
     nip ;;
   extend as-native ;; ( obj -- obj )
+  extend to-list drop 0 ;;
 drop
 
 MalNil
   extend conj ( item nil -- mal-list )
     drop MalList/Empty conj ;;
   extend as-native drop 0 ;;
-drop
-
-
-MalType%
-  cell% field MalInt/int
-deftype MalInt
-
-: MalInt. { int -- mal-int }
-    MalInt new dup MalInt/int int swap ! ;
-
-MalInt
-  extend mal= ( other this -- bool )
-    over mal-type @ MalInt = if
-        MalInt/int @ swap MalInt/int @ =
-    else
-        2drop 0
-    endif ;;
-
-  extend as-native ( mal-int -- int )
-    MalInt/int @ ;;
+  extend empty? drop mal-true ;;
+  extend mal-count drop 0 MalInt. ;;
+  extend mal= drop mal-nil = ;;
 drop
 
 MalType%
@@ -418,6 +462,9 @@ drop
 MalType%
   cell% field MalFn/xt
   cell% field MalFn/meta
+  cell% field MalFn/env
+  cell% field MalFn/formal-args
+  cell% field MalFn/body
 deftype MalFn
 
 : MalFn. { xt -- mal-fn }
-- 
cgit v1.2.3


From 136ce7c9afb5e103133fe6e423e6dad3d23db38d Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Sun, 15 Feb 2015 14:10:47 -0500
Subject: forth: Split types for user fns vs native fns

---
 forth/types.fs | 32 +++++++++++++++++++-------------
 1 file changed, 19 insertions(+), 13 deletions(-)

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
index 5eb546f..7675a5e 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -460,25 +460,31 @@ drop
 
 
 MalType%
-  cell% field MalFn/xt
-  cell% field MalFn/meta
-  cell% field MalFn/env
-  cell% field MalFn/formal-args
-  cell% field MalFn/body
-deftype MalFn
-
-: MalFn. { xt -- mal-fn }
-    MalFn new { mal-fn }
-    xt mal-fn MalFn/xt !
-    MalMap/Empty mal-fn MalFn/meta  !
+  cell% field MalNativeFn/xt
+  cell% field MalNativeFn/meta
+deftype MalNativeFn
+
+: MalNativeFn. { xt -- mal-fn }
+    MalNativeFn new { mal-fn }
+    xt mal-fn MalNativeFn/xt !
+    MalMap/Empty mal-fn MalNativeFn/meta  !
     mal-fn ;
 
-MalFn
+MalNativeFn
   extend as-native
-    MalFn/xt @ ;;
+    MalNativeFn/xt @ ;;
 drop
 
 
+MalType%
+  cell% field MalUserFn/meta
+  cell% field MalUserFn/env
+  cell% field MalUserFn/formal-args
+  cell% field MalUserFn/var-arg
+  cell% field MalUserFn/body
+deftype MalUserFn
+
+
 MalType%
   cell% field SpecialOp/xt
 deftype SpecialOp
-- 
cgit v1.2.3


From c4403c179e732a50e2b21a01469f0a38ea2d0187 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Sun, 15 Feb 2015 16:46:34 -0500
Subject: forth: Add support for & var-args

---
 forth/types.fs | 10 +++++++---
 1 file changed, 7 insertions(+), 3 deletions(-)

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
index 7675a5e..51f04ed 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -125,6 +125,8 @@ MalType% deftype MalFalse MalFalse new constant mal-false
 
 \ === protocol methods === /
 
+0 constant trace
+
 \ Used by protocol methods to find the appropriate implementation of
 \ themselves for the given object, and then execute that implementation.
 : execute-method { obj pxt -- }
@@ -153,10 +155,10 @@ MalType% deftype MalFalse MalFalse new constant mal-false
       ." '"
       1 throw
   endif
+  trace if ." Calling '" pxt >name name>string type ." ' on " obj mal-type @ type-name type cr endif
 
   cells swap MalTypeType-method-vals @ + @ ( xt )
-  obj swap execute
-  ;
+  obj swap execute ;
 
 \ Extend a type with a protocol method. This mutates the MalTypeType
 \ object that represents the MalType being extended.
@@ -313,13 +315,15 @@ deftype MalVector
 
 MalVector
   extend to-list
-    MalVector/list @ to-list ;;
+    MalVector/list @ ;;
   extend empty?
     MalVector/list @
     MalList/count @ 0= mal-bool ;;
   extend mal-count
     MalVector/list @
     MalList/count @ MalInt. ;;
+  extend mal=
+    MalVector/list @ swap m= ;;
 drop
 
 MalType%
-- 
cgit v1.2.3


From 785786c6033c97a70e78fb6b684d58aea18df4ae Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Sun, 15 Feb 2015 17:44:52 -0500
Subject: forth: Finish step 4

---
 forth/types.fs | 16 ++++++++--------
 1 file changed, 8 insertions(+), 8 deletions(-)

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
index 51f04ed..1a132be 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -118,7 +118,7 @@ MalType% deftype MalFalse MalFalse new constant mal-false
 
 : not-object? ( obj -- bool )
     dup 7 and 0 <> if
-        drop -1
+        drop true
     else
         1000000 <
     endif ;
@@ -232,7 +232,7 @@ def-protocol-method mal-count ( obj -- mal-int )
 
 : m= ( a b -- bool )
     2dup = if
-        2drop -1
+        2drop true
     else
         mal=
     endif ;
@@ -293,16 +293,16 @@ MalList
     else
         2dup MalList/count @ swap MalList/count @ over = if ( list-a list-b count )
             -rot MalList/start @ swap MalList/start @ { start-b start-a }
-            -1 swap ( return-val count )
+            true swap ( return-val count )
             0 ?do
                 start-a i cells + @
                 start-b i cells + @
                 m= if else
-                    drop 0 leave
+                    drop false leave
                 endif
             loop
         else
-            drop 2drop 0
+            drop 2drop false
         endif
     endif ;;
 drop
@@ -351,12 +351,12 @@ MalMap
     0
     begin
         dup count >= if
-            drop not-found -1
+            drop not-found true
         else
             start over cells + @ k m= if
-                start swap cells + cell+ @ -1 \ found it ( value -1 )
+                start swap cells + cell+ @ true \ found it ( value true )
             else
-                2 + 0
+                2 + false
             endif
         endif
     until ;;
-- 
cgit v1.2.3


From d44f31c2218a923d2a5b766ae3d6577aba294d42 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Sun, 15 Feb 2015 22:02:48 -0500
Subject: forth: Add step 5

---
 forth/types.fs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
index 1a132be..bf159ad 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -152,7 +152,7 @@ MalType% deftype MalFalse MalFalse new constant mal-false
       pxt >name name>string type
       ." ' extended to type '"
       obj mal-type @ type-name type
-      ." '"
+      ." '" cr
       1 throw
   endif
   trace if ." Calling '" pxt >name name>string type ." ' on " obj mal-type @ type-name type cr endif
-- 
cgit v1.2.3


From bf6a574e00a221dfe564ba11148deaa73ba8a229 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Mon, 16 Feb 2015 20:12:44 -0500
Subject: forth: Add step 6, clean up comment parsing

---
 forth/types.fs | 6 ++++++
 1 file changed, 6 insertions(+)

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
index bf159ad..5b8a211 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -309,6 +309,12 @@ drop
 
 MalList new 0 over MalList/count ! constant MalList/Empty
 
+: MalList/rest { list -- list }
+    MalList new
+    list MalList/start @   cell+   over MalList/start !
+    list MalList/count @   1-      over MalList/count ! ;
+
+
 MalType%
   cell% field MalVector/list
 deftype MalVector
-- 
cgit v1.2.3


From 794bfca1361fc6900f0ea0186d64111c3a02b0f8 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Mon, 16 Feb 2015 21:28:05 -0500
Subject: forth: Add step 7

---
 forth/types.fs | 1 +
 1 file changed, 1 insertion(+)

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
index 5b8a211..79965e8 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -380,6 +380,7 @@ MalDefault
     nip ;;
   extend as-native ;; ( obj -- obj )
   extend to-list drop 0 ;;
+  extend empty? drop mal-true ;;
 drop
 
 MalNil
-- 
cgit v1.2.3


From e82947d00f700558500e85e22aaf187544769a2e Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Tue, 17 Feb 2015 09:40:03 -0500
Subject: forth: Add step 8

---
 forth/types.fs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
index 79965e8..07eca02 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -488,7 +488,7 @@ drop
 
 
 MalType%
-  cell% field MalUserFn/meta
+  cell% field MalUserFn/is-macro?
   cell% field MalUserFn/env
   cell% field MalUserFn/formal-args
   cell% field MalUserFn/var-arg
-- 
cgit v1.2.3


From 580c4eef9d61f39264813b662fe5335c3c3c4ee5 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Tue, 17 Feb 2015 18:47:23 -0500
Subject: forth: Add step 9, just try*/throw

- Moved some stuff out of printer into str,
  to support throwing strings in types.fs
- Fixed an apparently completely broken 'nth'
- Still failing 120 step9 tests
---
 forth/types.fs | 19 ++++++++-----------
 1 file changed, 8 insertions(+), 11 deletions(-)

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
index 07eca02..d238001 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -1,3 +1,5 @@
+require str.fs
+
 \ === 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,
@@ -131,10 +133,8 @@ MalType% deftype MalFalse MalFalse new constant mal-false
 \ themselves for the given object, and then execute that implementation.
 : execute-method { obj pxt -- }
   obj not-object? if
-      ." Refusing to invoke protocol fn '"
-      pxt >name name>string type
-      ." ' on non-object: " obj .
-      1 throw
+      0 0 obj int>str s" ' on non-object: " pxt >name name>string
+      s" Refusing to invoke protocol fn '" ...throw-str
   endif
   obj mal-type @ dup MalTypeType-methods 2@ swap ( type methods method-keys )
   dup 0= if \ No protocols extended to this type; check for a default
@@ -148,12 +148,8 @@ MalType% deftype MalFalse MalFalse new constant mal-false
   endif
   0= if ( type idx )
       2drop
-      ." No protocol fn '"
-      pxt >name name>string type
-      ." ' extended to type '"
-      obj mal-type @ type-name type
-      ." '" cr
-      1 throw
+      0 0 s" '" obj mal-type @ type-name s" ' extended to type '"
+      pxt >name name>string s" No protocol fn '" ...throw-str
   endif
   trace if ." Calling '" pxt >name name>string type ." ' on " obj mal-type @ type-name type cr endif
 
@@ -449,11 +445,12 @@ MalType%
   cell% field MalString/str-len
 deftype MalString
 
-: MalString. { str-addr str-len -- mal-str }
+: MalString.0 { str-addr str-len -- mal-str }
     MalString new { str }
     str-addr str MalString/str-addr !
     str-len  str MalString/str-len  !
     str ;
+' MalString.0 is MalString.
 
 : unpack-str ( mal-string -- addr len )
     dup MalString/str-addr @
-- 
cgit v1.2.3


From 224e09ed42325f000ee9a31a500bebe03a1ba97c Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Wed, 18 Feb 2015 19:57:39 -0500
Subject: forth: Finish step 9

---
 forth/types.fs | 79 ++++++++++++++++++++++++++++++++++++++++++++++++++++------
 1 file changed, 72 insertions(+), 7 deletions(-)

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
index d238001..1ce74d9 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -59,6 +59,7 @@ require str.fs
 
 struct
   cell% field mal-type
+  cell% field mal-meta
   \ cell% field ref-count \ Ha, right.
 end-struct MalType%
 
@@ -74,6 +75,7 @@ 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
+  nil over mal-meta !
   ;
 
 : deftype* ( struct-align struct-len -- MalTypeType )
@@ -218,6 +220,7 @@ end-extend
 
 def-protocol-method conj ( obj this -- this )
 def-protocol-method assoc ( k v this -- this )
+def-protocol-method dissoc ( k this -- this )
 def-protocol-method get ( not-found k this -- value )
 def-protocol-method mal= ( a b -- bool )
 def-protocol-method as-native ( obj --  )
@@ -225,6 +228,20 @@ def-protocol-method as-native ( obj --  )
 def-protocol-method to-list ( obj -- mal-list )
 def-protocol-method empty? ( obj -- mal-bool )
 def-protocol-method mal-count ( obj -- mal-int )
+def-protocol-method sequential? ( obj -- mal-bool )
+
+
+\ Fully evalutate any Mal object:
+def-protocol-method mal-eval ( env ast -- val )
+
+\ Invoke an object, given whole env and unevaluated argument forms:
+def-protocol-method eval-invoke ( env list obj -- ... )
+
+\ Invoke a function, given parameter values
+def-protocol-method invoke ( argv argc mal-fn -- ... )
+
+
+
 
 : m= ( a b -- bool )
     2dup = if
@@ -259,6 +276,11 @@ MalType%
   cell% field MalList/start
 deftype MalList
 
+: MalList. ( start count -- mal-list )
+    MalList new
+    swap over MalList/count ! ( start list )
+    swap over MalList/start ! ( list ) ;
+
 : here>MalList ( old-here -- mal-list )
     here over - { bytes } ( old-here )
     MalList new bytes ( old-here mal-list bytes )
@@ -268,8 +290,22 @@ deftype MalList
     0 bytes - allot \ pop list contents from dictionary stack
     ;
 
+: MalList/concat ( list-of-lists )
+    dup MalList/start @ swap MalList/count @ { lists argc }
+    0   lists argc cells +  lists  +do ( count )
+        i @ to-list MalList/count @ +
+    cell +loop { count }
+    count cells allocate throw { start }
+    start   lists argc cells +  lists  +do ( target )
+        i @ to-list MalList/count @ cells  2dup  i @ to-list MalList/start @  -rot  ( target bytes src target bytes )
+        cmove ( target bytes )
+        + ( new-target )
+    cell +loop
+    drop start count MalList. ;
+
 MalList
   extend to-list ;;
+  extend sequential? drop mal-true ;;
   extend conj { elem old-list -- list }
     old-list MalList/count @ 1+ { new-count }
     new-count cells allocate throw { new-start }
@@ -277,10 +313,7 @@ MalList
     new-count 1 > if
       old-list MalList/start @   new-start cell+   new-count 1- cells  cmove
     endif
-
-    MalList new
-    new-count over MalList/count !
-    new-start over MalList/start ! ;;
+    new-start new-count MalList. ;;
   extend empty? MalList/count @ 0= mal-bool ;;
   extend mal-count MalList/count @ MalInt. ;;
   extend mal=
@@ -306,9 +339,9 @@ drop
 MalList new 0 over MalList/count ! constant MalList/Empty
 
 : MalList/rest { list -- list }
-    MalList new
-    list MalList/start @   cell+   over MalList/start !
-    list MalList/count @   1-      over MalList/count ! ;
+    list MalList/start @   cell+
+    list MalList/count @   1-
+    MalList. ;
 
 
 MalType%
@@ -316,6 +349,7 @@ MalType%
 deftype MalVector
 
 MalVector
+  extend sequential? drop mal-true ;;
   extend to-list
     MalVector/list @ ;;
   extend empty?
@@ -326,6 +360,15 @@ MalVector
     MalList/count @ MalInt. ;;
   extend mal=
     MalVector/list @ swap m= ;;
+  extend conj
+    MalVector/list @ { elem old-list }
+    old-list MalList/count @ { old-count }
+    old-count 1+ cells allocate throw { new-start }
+    elem new-start old-count cells + !
+    old-list MalList/start @   new-start old-count cells  cmove
+    new-start   old-count 1+  MalList.
+    MalVector new swap
+    over MalVector/list ! ;;
 drop
 
 MalType%
@@ -346,6 +389,19 @@ MalMap
     conj conj
     MalMap new dup -rot MalMap/list ! \ put back in map
     ;;
+  extend dissoc { k map -- map }
+    map MalMap/list @
+    dup MalList/start @ swap MalList/count @ { start count }
+    map \ return original if key not found
+    count 0 +do
+        start i cells + @ k mal= if
+            drop here
+            start i MalList. ,
+            start i 2 + cells +  count i - 2 - MalList. ,
+            here>MalList MalList/concat
+            MalMap new dup -rot MalMap/list ! \ put back in map
+        endif
+    2 +loop ;;
   extend get { not-found k map -- value }
     map MalMap/list @
     dup MalList/start @ { start }
@@ -377,12 +433,15 @@ MalDefault
   extend as-native ;; ( obj -- obj )
   extend to-list drop 0 ;;
   extend empty? drop mal-true ;;
+  extend sequential? drop mal-false ;;
 drop
 
 MalNil
   extend conj ( item nil -- mal-list )
     drop MalList/Empty conj ;;
   extend as-native drop 0 ;;
+  extend get drop 2drop mal-nil ;;
+  extend to-list drop MalList/Empty ;;
   extend empty? drop mal-true ;;
   extend mal-count drop 0 MalInt. ;;
   extend mal= drop mal-nil = ;;
@@ -499,3 +558,9 @@ deftype SpecialOp
 
 : SpecialOp.
     SpecialOp new swap over SpecialOp/xt ! ;
+
+MalType%
+  cell% field Atom/val
+deftype Atom
+
+: Atom. Atom new swap over Atom/val ! ;
-- 
cgit v1.2.3


From 6512bd80002eb106a304b035e9592847d90ef23c Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Thu, 19 Feb 2015 18:34:59 -0500
Subject: forth: Self-hosted mal passes all tests

---
 forth/types.fs | 31 ++++++++++++++++++-------------
 1 file changed, 18 insertions(+), 13 deletions(-)

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
index 1ce74d9..b936603 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -317,21 +317,25 @@ MalList
   extend empty? MalList/count @ 0= mal-bool ;;
   extend mal-count MalList/count @ MalInt. ;;
   extend mal=
-    swap to-list dup 0= if
-        nip
+    over mal-nil = if
+        2drop false
     else
-        2dup MalList/count @ swap MalList/count @ over = if ( list-a list-b count )
-            -rot MalList/start @ swap MalList/start @ { start-b start-a }
-            true swap ( return-val count )
-            0 ?do
-                start-a i cells + @
-                start-b i cells + @
-                m= if else
-                    drop false leave
-                endif
-            loop
+        swap to-list dup 0= if
+            nip
         else
-            drop 2drop false
+            2dup MalList/count @ swap MalList/count @ over = if ( list-a list-b count )
+                -rot MalList/start @ swap MalList/start @ { start-b start-a }
+                true swap ( return-val count )
+                0 ?do
+                    start-a i cells + @
+                    start-b i cells + @
+                    m= if else
+                        drop false leave
+                    endif
+                loop
+            else
+                drop 2drop false
+            endif
         endif
     endif ;;
 drop
@@ -434,6 +438,7 @@ MalDefault
   extend to-list drop 0 ;;
   extend empty? drop mal-true ;;
   extend sequential? drop mal-false ;;
+  extend mal= = ;;
 drop
 
 MalNil
-- 
cgit v1.2.3


From 45c1894b9690b1156ffdc2caeb726bbc9526597a Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Thu, 19 Feb 2015 19:42:52 -0500
Subject: forth: Back-propogate fixes from stepA through step1

---
 forth/types.fs | 2 --
 1 file changed, 2 deletions(-)

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
index b936603..791f327 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -241,8 +241,6 @@ def-protocol-method eval-invoke ( env list obj -- ... )
 def-protocol-method invoke ( argv argc mal-fn -- ... )
 
 
-
-
 : m= ( a b -- bool )
     2dup = if
         2drop true
-- 
cgit v1.2.3


From b254151c2a32203fe1920b4dd1db614ed2b0691b Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Fri, 20 Feb 2015 02:52:51 -0500
Subject: forth: Fix bug in extend-protocol array insertion

---
 forth/types.fs | 11 ++++++++---
 1 file changed, 8 insertions(+), 3 deletions(-)

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
index 791f327..5028bf3 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -30,8 +30,11 @@ require str.fs
       endif
     endif
   2dup = until
-  cells a-addr + @ key =
-  ;
+  dup a-length = if
+      drop false
+  else
+      cells a-addr + @ key =
+  endif ;
 
 \ Create a new array, one cell in length, initialized the provided value
 : new-array { value -- array }
@@ -170,7 +173,9 @@ MalType% deftype MalFalse MalFalse new constant mal-false
   else
     pxt array-find { idx found? }
     found? if \ overwrite
-      ." Warning: overwriting protocol method implementation"
+      ." Warning: overwriting protocol method implementation '"
+        pxt >name name>string safe-type ." ' on " type type-name safe-type ." , " idx . found? . cr
+
       type MalTypeType-method-vals @ idx cells + ixt !
     else \ resize
       type MalTypeType-methods dup @ 1+ dup rot ! ( new-count )
-- 
cgit v1.2.3


From b6607ac70f99ec0e465e3de1d9b397fea9b562ef Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Fri, 20 Feb 2015 02:54:17 -0500
Subject: forth: Fix bug in (get nil ...)

---
 forth/types.fs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'forth/types.fs')

diff --git a/forth/types.fs b/forth/types.fs
index 5028bf3..2c4c8e0 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -448,7 +448,7 @@ MalNil
   extend conj ( item nil -- mal-list )
     drop MalList/Empty conj ;;
   extend as-native drop 0 ;;
-  extend get drop 2drop mal-nil ;;
+  extend get 2drop ;;
   extend to-list drop MalList/Empty ;;
   extend empty? drop mal-true ;;
   extend mal-count drop 0 MalInt. ;;
-- 
cgit v1.2.3