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