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 : not-object? ( obj -- bool )
 112     dup 7 and 0 <> if
 113         drop -1
 114     else
 115         1000000 <
 116     endif ;
 117
 118 \ === protocol methods === /
 119
 120 \ Used by protocol methods to find the appropriate implementation of
 121 \ themselves for the given object, and then execute that implementation.
 122 : execute-method { obj pxt -- }
 123   obj not-object? if
 124       ." Refusing to invoke protocol fn '"
 125       pxt >name name>string type
 126       ." ' on non-object: " obj .
 127       1 throw
 128   endif
 129   obj mal-type @ dup MalTypeType-methods 2@ swap ( type methods method-keys )
 130   dup 0= if \ No protocols extended to this type; check for a default
 131     2drop drop MalDefault MalTypeType-methods 2@ swap
 132   endif
 133
 134   pxt array-find ( type idx found? )
 135   dup 0= if \ No implementation found for this method; check for a default
 136     2drop drop MalDefault dup MalTypeType-methods 2@ swap
 137     pxt array-find ( type idx found? )
 138   endif
 139   0= if ( type idx )
 140       2drop
 141       ." No protocol fn '"
 142       pxt >name name>string type
 143       ." ' extended to type '"
 144       obj mal-type @ type-name type
 145       ." '"
 146       1 throw
 147   endif
 148
 149   cells swap MalTypeType-method-vals @ + @ ( xt )
 150   obj swap execute
 151   ;
 152
 153 \ Extend a type with a protocol method. This mutates the MalTypeType
 154 \ object that represents the MalType being extended.
 155 : extend-method* { type pxt ixt -- type }
 156   type MalTypeType-methods 2@ swap ( methods method-keys )
 157   dup 0= if \ no protocols extended to this type
 158     2drop
 159     1 type MalTypeType-methods !
 160     pxt new-array type MalTypeType-method-keys !
 161     ixt new-array type MalTypeType-method-vals !
 162   else
 163     pxt array-find { idx found? }
 164     found? if \ overwrite
 165       ." Warning: overwriting protocol method implementation"
 166       type MalTypeType-method-vals @ idx cells + ixt !
 167     else \ resize
 168       type MalTypeType-methods dup @ 1+ dup rot ! ( new-count )
 169       1- dup type MalTypeType-method-keys @ idx pxt array-insert ( old-count new-array )
 170         type MalTypeType-method-keys ! ( old-count )
 171       type MalTypeType-method-vals @ idx ixt array-insert ( new-array )
 172         type MalTypeType-method-vals !
 173     endif
 174   endif
 175   type
 176   ;
 177
 178
 179 \ def-protocol-method pr-str   ...can be written:
 180 \ : pr-str ( obj -- str ) [ latestxt ] literal execute-method ;
 181 : def-protocol-method ( "name" -- )
 182     create latestxt ,
 183   does> ( ??? obj xt-ref -- ??? )
 184     @ execute-method ;
 185
 186 : extend ( type -- type pxt <noname...>)
 187     parse-name find-name name>int ( type pxt )
 188     :noname
 189     ;
 190
 191 : ;; ( type pxt <noname...> -- type )
 192     [compile] ; ( type pxt ixt )
 193     extend-method*
 194     ; immediate
 195
 196 (
 197 \ These whole-protocol names are only needed for 'satisfies?':
 198 protocol IPrintable
 199   def-protocol-method pr-str
 200 end-protocol
 201
 202 MalList IPrintable extend
 203   ' pr-str :noname drop s" <unprintable>" ; extend-method*
 204
 205   extend-method pr-str
 206     drop s" <unprintable>" ;;
 207 end-extend
 208 )
 209
 210 \ === Mal types and protocols === /
 211
 212 def-protocol-method conj ( obj this -- this )
 213 def-protocol-method assoc ( k v this -- this )
 214 def-protocol-method get ( not-found k this -- value )
 215 def-protocol-method mal= ( a b -- bool )
 216 def-protocol-method as-native ( obj --  )
 217 def-protocol-method to-list ( obj -- mal-list )
 218
 219 : m= ( a b -- bool )
 220     2dup = if
 221         2drop -1
 222     else
 223         mal=
 224     endif ;
 225
 226 MalType%
 227   cell% field MalList/count
 228   cell% field MalList/start
 229 deftype MalList
 230
 231 : here>MalList ( old-here -- mal-list )
 232     here over - { bytes } ( old-here )
 233     MalList new bytes ( old-here mal-list bytes )
 234     allocate throw dup { target } over MalList/start ! ( old-here mal-list )
 235     bytes cell / over MalList/count ! ( old-here mal-list )
 236     swap target bytes cmove ( mal-list )
 237     0 bytes - allot \ pop list contents from dictionary stack
 238     ;
 239
 240 MalList
 241   extend to-list ;;
 242   extend conj { elem old-list -- list }
 243     old-list MalList/count @ 1+ { new-count }
 244     new-count cells allocate throw { new-start }
 245     elem new-start !
 246     new-count 1 > if
 247       old-list MalList/start @   new-start cell+   new-count 1- cells  cmove
 248     endif
 249
 250     MalList new
 251     new-count over MalList/count !
 252     new-start over MalList/start ! ;;
 253 drop
 254
 255 MalList new 0 over MalList/count ! constant MalList/Empty
 256
 257 MalType%
 258   cell% field MalVector/list
 259 deftype MalVector
 260
 261 MalVector
 262   extend to-list
 263     MalVector/list @ to-list ;;
 264 drop
 265
 266 MalType%
 267   cell% field MalMap/list
 268 deftype MalMap
 269
 270 MalMap new MalList/Empty over MalMap/list ! constant MalMap/Empty
 271
 272 MalMap
 273   extend conj ( kv map -- map )
 274     MalMap/list @ \ get list
 275     over MalList/start @ cell+ @ swap conj \ add value
 276     swap MalList/start @ @ swap conj \ add key
 277     MalMap new dup -rot MalMap/list ! \ put back in map
 278     ;;
 279   extend assoc ( k v map -- map )
 280     MalMap/list @ \ get list
 281     conj conj
 282     MalMap new dup -rot MalMap/list ! \ put back in map
 283     ;;
 284   extend get { not-found k map -- value }
 285     map MalMap/list @
 286     dup MalList/start @ { start }
 287     MalList/count @ { count }
 288     0
 289     begin
 290         dup count >= if
 291             drop not-found -1
 292         else
 293             start over cells + @ k m= if
 294                 start swap cells + cell+ @ -1 \ found it ( value -1 )
 295             else
 296                 2 + 0
 297             endif
 298         endif
 299     until ;;
 300 drop
 301
 302 \ Examples of extending existing protocol methods to existing type
 303 MalDefault
 304   extend conj   ( obj this -- this )
 305     nip ;;
 306   extend as-native ;; ( obj -- obj )
 307 drop
 308
 309 MalNil
 310   extend conj ( item nil -- mal-list )
 311     drop MalList/Empty conj ;;
 312   extend as-native drop 0 ;;
 313 drop
 314
 315
 316 MalType%
 317   cell% field MalInt/int
 318 deftype MalInt
 319
 320 : MalInt. { int -- mal-int }
 321     MalInt new dup MalInt/int int swap ! ;
 322
 323 MalInt
 324   extend mal= ( other this -- bool )
 325     over mal-type @ MalInt = if
 326         MalInt/int @ swap MalInt/int @ =
 327     else
 328         2drop 0
 329     endif ;;
 330
 331   extend as-native ( mal-int -- int )
 332     MalInt/int @ ;;
 333 drop
 334
 335 MalType%
 336   cell% field MalSymbol/sym-addr
 337   cell% field MalSymbol/sym-len
 338   cell% field MalSymbol/meta
 339 deftype MalSymbol
 340
 341 : MalSymbol. { str-addr str-len -- mal-sym }
 342     MalSymbol new { sym }
 343     str-addr sym MalSymbol/sym-addr !
 344     str-len  sym MalSymbol/sym-len  !
 345     MalMap/Empty sym MalSymbol/meta  !
 346     sym ;
 347
 348 : unpack-sym ( mal-string -- addr len )
 349     dup MalSymbol/sym-addr @
 350     swap MalSymbol/sym-len @ ;
 351
 352 MalSymbol
 353   extend mal= ( other this -- bool )
 354     over mal-type @ MalSymbol = if
 355         unpack-sym rot unpack-sym str=
 356     else
 357         2drop 0
 358     endif ;;
 359   ' as-native ' unpack-sym extend-method*
 360 drop
 361
 362 MalType%
 363   cell% field MalKeyword/str-addr
 364   cell% field MalKeyword/str-len
 365 deftype MalKeyword
 366
 367 : unpack-keyword ( mal-keyword -- addr len )
 368     dup MalKeyword/str-addr @
 369     swap MalKeyword/str-len @ ;
 370
 371 MalKeyword
 372   extend mal= ( other this -- bool )
 373     over mal-type @ MalKeyword = if
 374         unpack-keyword rot unpack-keyword str=
 375     else
 376         2drop 0
 377     endif ;;
 378   ' as-native ' unpack-keyword extend-method*
 379 drop
 380
 381 : MalKeyword. { str-addr str-len -- mal-keyword }
 382     MalKeyword new { kw }
 383     str-addr kw MalKeyword/str-addr !
 384     str-len  kw MalKeyword/str-len  !
 385     kw ;
 386
 387 MalType%
 388   cell% field MalString/str-addr
 389   cell% field MalString/str-len
 390 deftype MalString
 391
 392 : MalString. { str-addr str-len -- mal-str }
 393     MalString new { str }
 394     str-addr str MalString/str-addr !
 395     str-len  str MalString/str-len  !
 396     str ;
 397
 398 : unpack-str ( mal-string -- addr len )
 399     dup MalString/str-addr @
 400     swap MalString/str-len @ ;
 401
 402 MalString
 403   extend mal= ( other this -- bool )
 404     over mal-type @ MalString = if
 405         unpack-str rot unpack-str str=
 406     else
 407         2drop 0
 408     endif ;;
 409   ' as-native ' unpack-str extend-method*
 410 drop
 411
 412
 413 MalType%
 414   cell% field MalFn/xt
 415   cell% field MalFn/meta
 416 deftype MalFn
 417
 418 : MalFn. { xt -- mal-fn }
 419     MalFn new { mal-fn }
 420     xt mal-fn MalFn/xt !
 421     MalMap/Empty mal-fn MalFn/meta  !
 422     mal-fn ;
 423
 424 MalFn
 425   extend as-native
 426     MalFn/xt @ ;;
 427 drop
 428
 429
 430 MalType%
 431   cell% field SpecialOp/xt
 432 deftype SpecialOp
 433
 434 : SpecialOp.
 435     SpecialOp new swap over SpecialOp/xt ! ;