forth/types.fs

   1 \ === sorted-array === /
   2 \ Here are a few utility functions useful for creating and maintaining
   3 \ the deftype* method tables. The keys array is kept in sorted order,
   4 \ and the methods array is maintained in parallel so that an index into
   5 \ one corresponds to an index in the other.
   6
   7 \ Search a sorted array for key, returning the index of where it was
   8 \ found. If key is not in the array, return the index where it would
   9 \ be if added.
  10 : array-find { a-length a-addr key -- index found? }
  11   0 a-length           ( start end )
  12   begin
  13     \ cr 2dup . .
  14     2dup + 2 / dup     ( start end middle middle )
  15     cells a-addr + @   ( start end middle mid-val )
  16     dup key < if
  17       drop rot         ( end middle start )
  18       2dup = if
  19         2drop dup      ( end end )
  20       else
  21         drop swap      ( middle end )
  22       endif
  23     else
  24       key > if         ( start end middle )
  25         nip            ( start middle )
  26       else
  27         -rot 2drop dup ( middle middle )
  28       endif
  29     endif
  30   2dup = until
  31   cells a-addr + @ key =
  32   ;
  33
  34 \ Create a new array, one cell in length, initialized the provided value
  35 : new-array { value -- array }
  36   cell allocate throw value over ! ;
  37
  38 \ Resize a heap-allocated array to be one cell longer, inserting value
  39 \ at idx, and shifting the tail of the array as necessary. Returns the
  40 \ (possibly new) array address
  41 : array-insert { old-array-length old-array idx value -- array }
  42   old-array old-array-length 1+ cells resize throw
  43   { a }
  44   a idx cells +   dup cell+   old-array-length idx - cells   cmove>
  45   value a idx cells + !
  46   a
  47   ;
  48
  49
  50 \ === deftype* -- protocol-enabled structs === /
  51 \ Each type has MalTypeType% struct allocated on the stack, with
  52 \ mutable fields pointing to all class-shared resources, specifically
  53 \ the data needed to allocate new instances, and the table of protocol
  54 \ methods that have been extended to the type.
  55 \ Use 'deftype*' to define a new type, and 'new' to create new
  56 \ instances of that type.
  57
  58 struct
  59   cell% field mal-type
  60   \ cell% field ref-count \ Ha, right.
  61 end-struct MalType%
  62
  63 struct
  64   cell% 2 * field MalTypeType-struct
  65   cell% field MalTypeType-methods
  66   cell% field MalTypeType-method-keys
  67   cell% field MalTypeType-method-vals
  68   cell% field MalTypeType-name-addr
  69   cell% field MalTypeType-name-len
  70 end-struct MalTypeType%
  71
  72 : new ( MalTypeType -- obj )
  73   dup MalTypeType-struct 2@ %allocate throw ( MalTypeType obj ) \ create struct
  74   dup -rot mal-type !                       ( obj ) \ set struct's type pointer to this type
  75   ;
  76
  77 : deftype* ( struct-align struct-len -- MalTypeType )
  78   MalTypeType% %allot                      ( s-a s-l MalTypeType )
  79   dup 2swap rot                            ( MalTypeType s-a s-l MalTypeType )
  80   MalTypeType-struct 2!                    ( MalTypeType ) \ store struct info
  81   dup MalTypeType-methods     0   swap !   ( MalTypeType )
  82   dup MalTypeType-method-keys nil swap !   ( MalTypeType )
  83   dup MalTypeType-method-vals nil swap !   ( MalTypeType )
  84   dup MalTypeType-name-len    0   swap !   ( MalTypeType )
  85   ;
  86
  87 : deftype ( struct-align struct-len R:type-name -- )
  88     parse-name { orig-name-addr name-len }
  89     \ parse-name uses temporary space, so copy into dictionary stack:
  90     here { name-addr } name-len allot
  91     orig-name-addr name-addr name-len cmove
  92
  93     \ allot and initialize type structure
  94     deftype* { mt }
  95     name-addr mt MalTypeType-name-addr !
  96     name-len  mt MalTypeType-name-len  !
  97     \ ." Defining " mt MalTypeType-name-addr @ mt MalTypeType-name-len @ type cr
  98     mt name-addr name-len nextname 1 0 const-does> ;
  99
 100 : type-name ( mal-type )
 101     dup  MalTypeType-name-addr @ ( mal-type name-addr )
 102     swap MalTypeType-name-len @ ( name-addr name-len )
 103     ;
 104
 105 MalType% deftype MalDefault
 106
 107 \ nil type and instance to support extending protocols to it
 108 MalType% deftype MalNil
 109 MalNil new constant mal-nil
 110
 111 \ === protocol methods === /
 112
 113 \ Used by protocol methods to find the appropriate implementation of
 114 \ themselves for the given object, and then execute that implementation.
 115 : execute-method { obj pxt -- }
 116   obj mal-type @ dup MalTypeType-methods 2@ swap ( type methods method-keys )
 117   dup 0= if \ No protocols extended to this type; check for a default
 118     2drop drop MalDefault MalTypeType-methods 2@ swap
 119   endif
 120   dup 0= if ." No protocols extended to this type or MalDefault" 1 throw endif
 121
 122   pxt array-find ( type idx found? )
 123   dup 0= if \ No implementation found for this method; check for a default
 124     2drop drop MalDefault dup MalTypeType-methods 2@ swap
 125     dup 0= if ." No implementation found for this method, and no protocols extended to MalDefault" 1 throw endif
 126     pxt array-find ( type idx found? )
 127   endif
 128   0= if ( type idx )
 129       2drop
 130       ." No protocol fn '"
 131       pxt >name name>string type
 132       ." ' extended to type '"
 133       obj mal-type @ type-name type
 134       ." '"
 135       1 throw
 136   endif
 137
 138   cells swap MalTypeType-method-vals @ + @ ( xt )
 139   obj swap execute
 140   ;
 141
 142 \ Extend a type with a protocol method. This mutates the MalTypeType
 143 \ object that represents the MalType being extended.
 144 : extend-method* { type pxt ixt -- type }
 145   type MalTypeType-methods 2@ swap ( methods method-keys )
 146   dup 0= if \ no protocols extended to this type
 147     2drop
 148     1 type MalTypeType-methods !
 149     pxt new-array type MalTypeType-method-keys !
 150     ixt new-array type MalTypeType-method-vals !
 151   else
 152     pxt array-find { idx found? }
 153     found? if \ overwrite
 154       ." Warning: overwriting protocol method implementation"
 155       type MalTypeType-method-vals @ idx cells + ixt !
 156     else \ resize
 157       type MalTypeType-methods dup @ 1+ dup rot ! ( new-count )
 158       1- dup type MalTypeType-method-keys @ idx pxt array-insert ( old-count new-array )
 159         type MalTypeType-method-keys ! ( old-count )
 160       \ cr ." before: " MalList MalTypeType-method-vals @ @ . cr
 161       type MalTypeType-method-vals @ idx ixt array-insert ( new-array )
 162         type MalTypeType-method-vals !
 163       \ cr ." after: " MalList MalTypeType-method-vals @ @ . cr
 164     endif
 165   endif
 166   type
 167   ;
 168
 169
 170 \ def-protocol-method pr-str   ...can be written:
 171 \ : pr-str ( obj -- str ) [ latestxt ] literal execute-method ;
 172 : def-protocol-method ( "name" -- )
 173     create latestxt ,
 174   does> ( ??? obj xt-ref -- ??? )
 175     @ execute-method ;
 176
 177 : extend ( type -- type pxt <noname...>)
 178     parse-name find-name name>int ( type pxt )
 179     :noname
 180     ;
 181
 182 : ;; ( type pxt <noname...> -- type )
 183     [compile] ; ( type pxt ixt )
 184     extend-method*
 185     ; immediate
 186
 187 (
 188 \ These whole-protocol names are only needed for 'satisfies?':
 189 protocol IPrintable
 190   def-protocol-method pr-str
 191 end-protocol
 192
 193 MalList IPrintable extend
 194   ' pr-str :noname drop s" <unprintable>" ; extend-method*
 195
 196   extend-method pr-str
 197     drop s" <unprintable>" ;;
 198 end-extend
 199 )
 200
 201 \ === Mal types and protocols === /
 202
 203 MalType%
 204   cell% field MalList/car
 205   cell% field MalList/cdr
 206 deftype MalList
 207
 208 : MalList/conj { val coll -- list }
 209     MalList new ( list )
 210     val over MalList/car ! ( list )
 211     coll over MalList/cdr ! ( list )
 212     ;
 213
 214 MalType%
 215   cell% field MalArray/count
 216   cell% field MalArray/start
 217 deftype MalArray
 218
 219 : here>MalArray ( old-here -- mal-array )
 220     here over - { bytes } ( old-here )
 221     MalArray new bytes ( old-here mal-array bytes )
 222     allocate throw dup { target } over MalArray/start ! ( old-here mal-array )
 223     bytes cell / over MalArray/count ! ( old-here mal-array )
 224     swap target bytes cmove ( mal-array )
 225     0 bytes - allot \ pop array contents from dictionary stack
 226     ;
 227
 228 def-protocol-method conj ( obj this -- this )
 229 def-protocol-method assoc ( k v this -- this )
 230 def-protocol-method get ( not-found k this -- value )
 231 def-protocol-method mal= ( a b -- bool )
 232 def-protocol-method as-native ( obj --  )
 233 def-protocol-method invoke ( argv argc mal-fn -- ... )
 234
 235 MalType%
 236   cell% field MalVector/list
 237 deftype MalVector
 238
 239 MalType%
 240   cell% field MalMap/list
 241 deftype MalMap
 242
 243 MalMap new mal-nil over MalMap/list ! constant MalMap/Empty
 244
 245 MalMap
 246   extend conj ( kv map -- map )
 247     MalMap/list @ \ get list
 248     over MalList/cdr @ MalList/car @ conj \ add value
 249     swap MalList/car @ conj \ add key
 250     MalMap new MalMap/list ! \ put back in map
 251     ;;
 252   extend assoc ( k v map -- map )
 253     MalMap/list @ \ get list
 254     conj conj
 255     MalMap new dup -rot MalMap/list ! \ put back in map
 256     ;;
 257   extend get ( not-found k map -- value )
 258     -rot { not-found k }
 259     MalMap/list @ \ get list
 260     begin
 261         dup MalList/cdr @
 262         swap MalList/car @ k mal= if
 263             MalList/car @ -1 \ found it
 264         else
 265             MalList/cdr @
 266             dup mal-nil = if
 267                 not-found -1
 268             else
 269                 0
 270             endif
 271         endif
 272     until ;;
 273 drop
 274
 275 \ Examples of extending existing protocol methods to existing type
 276 MalDefault
 277   extend conj   ( obj this -- this )
 278     nip ;;
 279   extend as-native ;; ( obj -- obj )
 280 drop
 281
 282 MalNil
 283   ' conj ' MalList/conj extend-method*
 284   extend as-native drop 0 ;;
 285 drop
 286
 287 MalList
 288   ' conj ' MalList/conj extend-method*
 289 drop
 290
 291
 292 MalType%
 293   cell% field MalInt/int
 294 deftype MalInt
 295
 296 : MalInt. { int -- mal-int }
 297     MalInt new dup MalInt/int int swap ! ;
 298
 299 MalInt
 300   extend as-native ( mal-int -- int )
 301     MalInt/int @ ;;
 302 drop
 303
 304 MalType%
 305   cell% field MalSymbol/sym-addr
 306   cell% field MalSymbol/sym-len
 307   cell% field MalSymbol/meta
 308 deftype MalSymbol
 309
 310 : MalSymbol. { str-addr str-len -- mal-sym }
 311     MalSymbol new { sym }
 312     str-addr sym MalSymbol/sym-addr !
 313     str-len  sym MalSymbol/sym-len  !
 314     MalMap/Empty sym MalSymbol/meta  !
 315     sym ;
 316
 317 : unpack-sym ( mal-string -- addr len )
 318     dup MalSymbol/sym-addr @
 319     swap MalSymbol/sym-len @ ;
 320
 321 MalSymbol
 322   extend mal= ( other this -- bool )
 323     over mal-type @ MalSymbol = if
 324         unpack-sym rot unpack-sym str=
 325     else
 326         2drop 0
 327     endif ;;
 328   ' as-native ' unpack-sym extend-method*
 329 drop
 330
 331 MalType%
 332   cell% field MalKeyword/str-addr
 333   cell% field MalKeyword/str-len
 334 deftype MalKeyword
 335
 336 : unpack-keyword ( mal-keyword -- addr len )
 337     dup MalKeyword/str-addr @
 338     swap MalKeyword/str-len @ ;
 339
 340 MalKeyword
 341   extend mal= ( other this -- bool )
 342     over mal-type @ MalKeyword = if
 343         unpack-keyword rot unpack-keyword str=
 344     else
 345         2drop 0
 346     endif ;;
 347   ' as-native ' unpack-keyword extend-method*
 348   extend invoke { argv argc kw -- val }
 349     argc 1 > if argv cell+ @ else mal-nil endif \ not-found
 350     kw \ key
 351     argv @ \ map
 352     get ;;
 353 drop
 354
 355 : MalKeyword. { str-addr str-len -- mal-keyword }
 356     MalKeyword new { kw }
 357     str-addr kw MalKeyword/str-addr !
 358     str-len  kw MalKeyword/str-len  !
 359     kw ;
 360
 361 MalType%
 362   cell% field MalString/str-addr
 363   cell% field MalString/str-len
 364 deftype MalString
 365
 366 : MalString. { str-addr str-len -- mal-str }
 367     MalString new { str }
 368     str-addr str MalString/str-addr !
 369     str-len  str MalString/str-len  !
 370     str ;
 371
 372 : unpack-str ( mal-string -- addr len )
 373     dup MalString/str-addr @
 374     swap MalString/str-len @ ;
 375
 376 MalString
 377   extend mal= ( other this -- bool )
 378     over mal-type @ MalString = if
 379         unpack-str rot unpack-str str=
 380     else
 381         2drop 0
 382     endif ;;
 383   ' as-native ' unpack-str extend-method*
 384 drop
 385
 386
 387 MalType%
 388   cell% field MalFn/xt
 389   cell% field MalFn/meta
 390 deftype MalFn
 391
 392 : MalFn. { xt -- mal-fn }
 393     MalFn new { mal-fn }
 394     xt mal-fn MalFn/xt !
 395     MalMap/Empty mal-fn MalFn/meta  !
 396     mal-fn ;
 397
 398 MalFn
 399   extend invoke ( ... mal-fn -- ... )
 400     MalFn/xt @ execute ;;
 401   extend as-native
 402     MalFn/xt @ ;;
 403 drop