forth: Start experimenting

1 files changed, 247 insertions, 0 deletions

diff --git a/forth/types.f b/forth/types.f
new file mode 100644
index 0000000..e30733f
--- /dev/null
+++ b/forth/types.f
@@ -0,0 +1,247 @@
+\ === 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
+
+: test=
+  2dup = if
+    2drop
+  else
+    cr ." assert failed on line " sourceline# .
+    swap cr ." | got " . cr ." | expected " . cr
+  endif ;
+
+\ new-class
+
+struct
+  cell% 2 * field MalTypeType-struct
+  cell% field MalTypeType-methods
+end-struct MalTypeType%
+
+struct
+  cell% field mal-type
+  \ cell% field ref-count \ Ha, right.
+end-struct MalType%
+
+: 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 nil swap ! ( MalTypeType ) \ init methods to nil
+  ;
+
+\ Example:
+
+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=
+
+\ 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.
+: aarray-find { aa-length aa-addr key -- index }
+  0 aa-length ( start end )
+  begin
+    \ cr 2dup . .
+    2dup + 2 / dup ( start end middle middle )
+    cells aa-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
+  drop
+  ;
+
+create zaa 2 , 6 , 7 , 10 , 15 , 80 , 81 ,
+
+7 zaa 2 aarray-find   0 test=
+7 zaa 6 aarray-find   1 test=
+7 zaa 10 aarray-find  3 test=
+7 zaa 81 aarray-find  6 test=
+7 zaa 12 aarray-find  4 test=
+7 zaa 8  aarray-find  3 test=
+7 zaa 100 aarray-find 7 test=
+7 zaa 1 aarray-find   0 test=
+
+\ manual protocol method
+
+0 value method-count
+
+: pr-str ( ?? obj -- ?? )
+  dup mal-type @ MalTypeType-methods @ ( obj methods )
+  [ method-count ] literal aarray-find ( obj xt )
+  execute ;
+
+
+(
+  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
+
+
+bye
+
+)
+
+cr ." Done loading" cr