forth: Add basic protocol functionality

1 files changed, 351 insertions, 0 deletions

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