forth/types.fs

   1 \ === tiny framework for inline tests === /
   2 : test=
   3   2dup = if
   4     2drop
   5   else
   6     cr ." assert failed on line " sourceline# .
   7     swap cr ." | got " . cr ." | expected " . cr
   8   endif ;
   9
  10 \ === classic lisp list === /
  11 : cons { addr val -- new-list-address }
  12   2 cells allocate throw
  13   dup addr val rot 2! ;
  14
  15 : cdr ( addr -- next-addr )
  16   cell+ @ ;
  17
  18 : int-pr ( num -- )
  19   s>d <# #s #> type ;
  20
  21 : prn ( list-address -- )
  22   ." (" 2@ int-pr
  23   begin
  24     space 2@ int-pr
  25     dup 0=
  26   until
  27   .\" )\n" ;
  28
  29 0 1 cons 2 cons 3 cons 4 cons
  30 prn
  31
  32
  33 \ === mutable vector === /
  34 \ Singly-linked list, with an "object" pair that points to both ends.
  35 \ This allows fast append and fast iteration from beginning to end,
  36 \ like a vector.  ...but buys simplicity with mutability
  37 : new-mutvec ( -- mutvec-addr )
  38   2 cells allocate throw
  39   dup 0 0 rot 2! ;
  40
  41 : mutvec-append { mutvec-addr value -- }
  42   2 cells allocate throw    \ new pair
  43   dup nil value rot 2!      \ put value in new pair
  44   dup mutvec-addr @
  45     ?dup 0= if mutvec-addr endif
  46     cell+ !                 \ update old tail
  47   mutvec-addr !             \ update object
  48   ;
  49
  50 new-mutvec
  51 dup 5 mutvec-append
  52 dup 4 mutvec-append
  53 dup 3 mutvec-append
  54 dup 2 mutvec-append
  55 cdr prn
  56
  57
  58 \ === mutable string buffer === /
  59 \ string buffer that maintains an allocation larger than the current
  60 \ string size.  When appending would cause the string size exceed the
  61 \ current allocation, resize is used to double the allocation. The
  62 \ current allocation is not stored anywhere, but computed based on
  63 \ current string size or str-base-size, whichever is larger.
  64 64 constant str-base-size
  65
  66 : new-str ( -- addr length )
  67   str-base-size allocate throw 0 ;
  68
  69 : round-up ( n -- n )
  70   2
  71   begin
  72     1 lshift 2dup <
  73   until
  74   swap drop ;
  75
  76 : str-append { buf-addr buf-str-len str-addr str-len }
  77   buf-str-len str-len +
  78   { new-len }
  79   new-len str-base-size > if
  80     buf-str-len new-len xor buf-str-len > if
  81       buf-addr new-len round-up resize throw
  82       to buf-addr
  83     endif
  84   endif
  85   str-addr buf-addr buf-str-len + str-len cmove
  86   buf-addr new-len ;
  87
  88
  89 bl c,
  90 here constant space-str
  91 : a-space space-str 1 str-append ;
  92
  93 new-str
  94 s" hello there" str-append a-space
  95 s" is this getting ...." str-append a-space
  96 s\" interesting yet?\n" str-append
  97 type
  98
  99 \ A rewrite of the list-printer above, but now using string buffer:
 100 : int-pr-str2 ( num -- str-addr str-len )
 101   s>d <# #s #> ;
 102
 103 : pr-str2 ( strbuf str-len list-address -- )
 104   -rot s" (" str-append rot
 105   2@ 2swap rot int-pr-str2 str-append
 106   begin
 107     a-space
 108     rot 2@ 2swap rot int-pr-str2 str-append
 109     2 pick 0=
 110   until
 111   s" )" str-append rot drop ;
 112
 113 new-str
 114 0 1 cons 2 cons 3 cons 4 cons
 115 pr-str2 type
 116 cr
 117
 118 \ === deftype* -- protocol-enabled structs === /
 119 \ Each type has MalTypeType% struct allocated on the stack, with
 120 \ mutable fields pointing to all class-shared resources, specifically
 121 \ the data needed to allocate new instances, and the table of protocol
 122 \ methods that have been extended to the type.
 123 \ Use 'deftype*' to define a new type, and 'new' to create new
 124 \ instances of that type.
 125
 126 struct
 127   cell% field mal-type
 128   \ cell% field ref-count \ Ha, right.
 129 end-struct MalType%
 130
 131 struct
 132   cell% 2 * field MalTypeType-struct
 133   cell% field MalTypeType-methods
 134   cell% field MalTypeType-method-keys
 135   cell% field MalTypeType-method-vals
 136 end-struct MalTypeType%
 137
 138 : new ( MalTypeType -- obj )
 139   dup MalTypeType-struct 2@ %allocate throw ( MalTypeType obj ) \ create struct
 140   dup -rot mal-type !                       ( obj ) \ set struct's type pointer to this type
 141   ;
 142
 143 : deftype* ( struct-align struct-len -- MalTypeType )
 144   MalTypeType% %allot                      ( s-a s-l MalTypeType )
 145   dup 2swap rot                            ( MalTypeType s-a s-l MalTypeType )
 146   MalTypeType-struct 2!                    ( MalTypeType ) \ store struct info
 147   dup MalTypeType-methods     0   swap !   ( MalTypeType )
 148   dup MalTypeType-method-keys nil swap !   ( MalTypeType )
 149   dup MalTypeType-method-vals nil swap !   ( MalTypeType )
 150   ;
 151
 152 MalType% deftype* constant MalDefault
 153
 154 \ Example and tests
 155
 156 MalType%
 157   cell% field obj-list/car
 158   cell% field obj-list/cdr
 159 deftype* constant ObjList
 160
 161 ObjList new
 162 ObjList new
 163 = 0 test=
 164
 165 ObjList new dup obj-list/car 5 swap ! obj-list/car @   5 test=
 166
 167 \ === sorted-array === /
 168 \ Here are a few utility functions useful for creating and maintaining
 169 \ the deftype* method tables. The keys array is kept in sorted order,
 170 \ and the methods array is maintained in parallel so that an index into
 171 \ one corresponds to an index in the other.
 172
 173 \ Search a sorted array for key, returning the index of where it was
 174 \ found. If key is not in the array, return the index where it would
 175 \ be if added.
 176 : array-find { a-length a-addr key -- index found? }
 177   0 a-length           ( start end )
 178   begin
 179     \ cr 2dup . .
 180     2dup + 2 / dup     ( start end middle middle )
 181     cells a-addr + @   ( start end middle mid-val )
 182     dup key < if
 183       drop rot         ( end middle start )
 184       2dup = if
 185         2drop dup      ( end end )
 186       else
 187         drop swap      ( middle end )
 188       endif
 189     else
 190       key > if         ( start end middle )
 191         swap drop      ( start middle )
 192       else
 193         -rot 2drop dup ( middle middle )
 194       endif
 195     endif
 196   2dup = until
 197   cells a-addr + @ key =
 198   ;
 199
 200 \ Create a new array, one cell in length, initialized the provided value
 201 : new-array { value -- array }
 202   cell allocate throw value over ! ;
 203
 204 \ Resize a heap-allocated array to be one cell longer, inserting value
 205 \ at idx, and shifting the tail of the array as necessary. Returns the
 206 \ (possibly new) array address
 207 : array-insert { old-array-length old-array idx value -- array }
 208   old-array old-array-length 1+ cells resize throw
 209   { a }
 210   a idx cells +   dup cell+   old-array-length idx - cells   cmove>
 211   value a idx cells + !
 212   a
 213   ;
 214
 215 \ array function tests
 216 create za 2 , 6 , 7 , 10 , 15 , 80 , 81 ,
 217
 218 7 za 2 array-find   -1 test= 0 test=
 219 7 za 6 array-find   -1 test= 1 test=
 220 7 za 10 array-find  -1 test= 3 test=
 221 7 za 81 array-find  -1 test= 6 test=
 222 7 za 12 array-find   0 test= 4 test=
 223 7 za 8  array-find   0 test= 3 test=
 224 7 za 100 array-find  0 test= 7 test=
 225 7 za 1 array-find    0 test= 0 test=
 226
 227 10 new-array
 228 1 swap 0  5 array-insert
 229 2 swap 1  7 array-insert
 230 3 swap 3 12 array-insert
 231 4 swap 4 15 array-insert
 232 5 swap 5 20 array-insert
 233
 234 dup 0 cells + @   5 test=
 235 dup 1 cells + @   7 test=
 236 dup 2 cells + @  10 test=
 237 dup 3 cells + @  12 test=
 238 dup 4 cells + @  15 test=
 239 dup 5 cells + @  20 test=
 240
 241
 242 \ === protocol methods === /
 243
 244 \ Used by protocol methods to find the appropriate implementation of
 245 \ themselves for the given object, and then execute that implementation.
 246 : execute-method { obj pxt -- }
 247   obj mal-type @ dup MalTypeType-methods 2@ swap ( type methods method-keys )
 248   dup 0= if \ No protocols extended to this type; check for a default
 249     2drop drop MalDefault MalTypeType-methods 2@ swap
 250   endif
 251   dup 0= if ." No protocols extended to this type or MalDefault" 1 throw endif
 252
 253   pxt array-find ( type idx found? )
 254   dup 0= if \ No implementation found for this method; check for a default
 255     2drop MalDefault MalTypeType-methods 2@ swap
 256     dup 0= if ." No implementation found for this method, and no protocols extended to MalDefault" 1 throw endif
 257     pxt array-find ( type idx found? )
 258   endif
 259   0= if ." No implementation found" 1 throw endif
 260
 261   cells swap MalTypeType-method-vals @ + @ ( xt )
 262   obj swap execute
 263   ;
 264
 265 \ Extend a type with a protocol method. This mutates the MalTypeType
 266 \ object that represents the MalType being extended.
 267 : extend-method* { type pxt ixt -- type }
 268   type MalTypeType-methods 2@ swap ( methods method-keys )
 269   dup 0= if \ no protocols extended to this type
 270     2drop
 271     1 type MalTypeType-methods !
 272     pxt new-array type MalTypeType-method-keys !
 273     ixt new-array type MalTypeType-method-vals !
 274   else
 275     pxt array-find { idx found? }
 276     found? if \ overwrite
 277       ." Warning: overwriting protocol method implementation"
 278       type MalTypeType-method-vals @ idx cells + ixt !
 279     else \ resize
 280       type MalTypeType-methods dup @ 1+ dup rot ! ( new-count )
 281       1- dup type MalTypeType-method-keys @ idx pxt array-insert ( old-count new-array )
 282         type MalTypeType-method-keys ! ( old-count )
 283       \ cr ." before: " ObjList MalTypeType-method-vals @ @ . cr
 284       type MalTypeType-method-vals @ idx ixt array-insert ( new-array )
 285         type MalTypeType-method-vals !
 286       \ cr ." after: " ObjList MalTypeType-method-vals @ @ . cr
 287     endif
 288   endif
 289   type
 290   ;
 291
 292 \ Examples of making new protocol methods (without a protocol to group them yet!)
 293 : pr-str [ latestxt ] literal execute-method ;
 294 : conj   [ latestxt ] literal execute-method ;
 295
 296 \ Examples of extending existing protocol methods to existing type
 297 MalDefault ' pr-str :noname s" #<MalObject>" ; extend-method*
 298 ObjList ' pr-str :noname drop s" #<ObjList>" ; extend-method*
 299 ObjList ' conj :noname ." not yet done" ; extend-method*
 300
 301 \ Run some protocol methods!
 302 ObjList new pr-str type
 303 ObjList new conj
 304
 305 (
 306   method-count 1+ to method-count
 307
 308 protocol IPrintable
 309   method% pr-str
 310 end-protocol
 311 )
 312
 313 (
 314 ObjList IPrintable extend
 315
 316   ' pr-str :noname drop s" <unprintable>" ; extend-method*
 317
 318   extend-method pr-str
 319     drop s" <unprintable>" ;
 320 end-extend
 321 )
 322
 323 \ new-obj
 324
 325 \ new-instance
 326
 327
 328 \ maybe useful for debugging?
 329 : p dup . ;
 330 : @p dup @ dup . ;
 331
 332 (
 333
 334 create buff 128 allot
 335
 336 ." user> "
 337
 338 buff 128 stdin read-line throw
 339
 340 buff c@ .
 341 buff 5 + c@ .
 342
 343 S" Hello" dup . type
 344
 345
 346 )
 347
 348
 349 cr
 350 bye
 351 ." Done loading" cr