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 \ parse-name uses temporary space, so copy into dictionary stack:
  88 : parse-allot-name { -- new-str-addr str-len }
  89     parse-name { str-addr str-len }
  90     here { new-str-addr } str-len allot
  91     str-addr new-str-addr str-len cmove
  92     new-str-addr str-len ;
  93
  94 : deftype ( struct-align struct-len R:type-name -- )
  95     parse-allot-name { name-addr name-len }
  96
  97     \ allot and initialize type structure
  98     deftype* { mt }
  99     name-addr mt MalTypeType-name-addr !
 100     name-len  mt MalTypeType-name-len  !
 101     \ ." Defining " mt MalTypeType-name-addr @ mt MalTypeType-name-len @ type cr
 102     mt name-addr name-len nextname 1 0 const-does> ;
 103
 104 : type-name ( mal-type )
 105     dup  MalTypeType-name-addr @ ( mal-type name-addr )
 106     swap MalTypeType-name-len @ ( name-addr name-len )
 107     ;
 108
 109 MalType% deftype MalDefault
 110
 111 \ nil type and instance to support extending protocols to it
 112 MalType% deftype MalNil   MalNil   new constant mal-nil
 113 MalType% deftype MalTrue  MalTrue  new constant mal-true
 114 MalType% deftype MalFalse MalFalse new constant mal-false
 115
 116 : mal-bool
 117     0= if mal-false else mal-true endif ;
 118
 119 : not-object? ( obj -- bool )
 120     dup 7 and 0 <> if
 121         drop true
 122     else
 123         1000000 <
 124     endif ;
 125
 126 \ === protocol methods === /
 127
 128 0 constant trace
 129
 130 \ Used by protocol methods to find the appropriate implementation of
 131 \ themselves for the given object, and then execute that implementation.
 132 : execute-method { obj pxt -- }
 133   obj not-object? if
 134       ." Refusing to invoke protocol fn '"
 135       pxt >name name>string type
 136       ." ' on non-object: " obj .
 137       1 throw
 138   endif
 139   obj mal-type @ dup MalTypeType-methods 2@ swap ( type methods method-keys )
 140   dup 0= if \ No protocols extended to this type; check for a default
 141     2drop drop MalDefault MalTypeType-methods 2@ swap
 142   endif
 143
 144   pxt array-find ( type idx found? )
 145   dup 0= if \ No implementation found for this method; check for a default
 146     2drop drop MalDefault dup MalTypeType-methods 2@ swap
 147     pxt array-find ( type idx found? )
 148   endif
 149   0= if ( type idx )
 150       2drop
 151       ." No protocol fn '"
 152       pxt >name name>string type
 153       ." ' extended to type '"
 154       obj mal-type @ type-name type
 155       ." '" cr
 156       1 throw
 157   endif
 158   trace if ." Calling '" pxt >name name>string type ." ' on " obj mal-type @ type-name type cr endif
 159
 160   cells swap MalTypeType-method-vals @ + @ ( xt )
 161   obj swap execute ;
 162
 163 \ Extend a type with a protocol method. This mutates the MalTypeType
 164 \ object that represents the MalType being extended.
 165 : extend-method* { type pxt ixt -- type }
 166   type MalTypeType-methods 2@ swap ( methods method-keys )
 167   dup 0= if \ no protocols extended to this type
 168     2drop
 169     1 type MalTypeType-methods !
 170     pxt new-array type MalTypeType-method-keys !
 171     ixt new-array type MalTypeType-method-vals !
 172   else
 173     pxt array-find { idx found? }
 174     found? if \ overwrite
 175       ." Warning: overwriting protocol method implementation"
 176       type MalTypeType-method-vals @ idx cells + ixt !
 177     else \ resize
 178       type MalTypeType-methods dup @ 1+ dup rot ! ( new-count )
 179       1- dup type MalTypeType-method-keys @ idx pxt array-insert ( old-count new-array )
 180         type MalTypeType-method-keys ! ( old-count )
 181       type MalTypeType-method-vals @ idx ixt array-insert ( new-array )
 182         type MalTypeType-method-vals !
 183     endif
 184   endif
 185   type
 186   ;
 187
 188
 189 \ def-protocol-method pr-str   ...can be written:
 190 \ : pr-str ( obj -- str ) [ latestxt ] literal execute-method ;
 191 : def-protocol-method ( "name" -- )
 192     create latestxt ,
 193   does> ( ??? obj xt-ref -- ??? )
 194     @ execute-method ;
 195
 196 : extend ( type -- type pxt install-xt <noname...>)
 197     parse-name find-name name>int ( type pxt )
 198     ['] extend-method*
 199     :noname
 200     ;
 201
 202 : ;; ( type pxt <noname...> -- type )
 203     [compile] ; ( type pxt install-xt ixt )
 204     swap execute
 205     ; immediate
 206
 207 (
 208 \ These whole-protocol names are only needed for 'satisfies?':
 209 protocol IPrintable
 210   def-protocol-method pr-str
 211 end-protocol
 212
 213 MalList IPrintable extend
 214   ' pr-str :noname drop s" <unprintable>" ; extend-method*
 215
 216   extend-method pr-str
 217     drop s" <unprintable>" ;;
 218 end-extend
 219 )
 220
 221 \ === Mal types and protocols === /
 222
 223 def-protocol-method conj ( obj this -- this )
 224 def-protocol-method assoc ( k v this -- this )
 225 def-protocol-method get ( not-found k this -- value )
 226 def-protocol-method mal= ( a b -- bool )
 227 def-protocol-method as-native ( obj --  )
 228
 229 def-protocol-method to-list ( obj -- mal-list )
 230 def-protocol-method empty? ( obj -- mal-bool )
 231 def-protocol-method mal-count ( obj -- mal-int )
 232
 233 : m= ( a b -- bool )
 234     2dup = if
 235         2drop true
 236     else
 237         mal=
 238     endif ;
 239
 240
 241 MalType%
 242   cell% field MalInt/int
 243 deftype MalInt
 244
 245 : MalInt. { int -- mal-int }
 246     MalInt new dup MalInt/int int swap ! ;
 247
 248 MalInt
 249   extend mal= ( other this -- bool )
 250     over mal-type @ MalInt = if
 251         MalInt/int @ swap MalInt/int @ =
 252     else
 253         2drop 0
 254     endif ;;
 255
 256   extend as-native ( mal-int -- int )
 257     MalInt/int @ ;;
 258 drop
 259
 260
 261 MalType%
 262   cell% field MalList/count
 263   cell% field MalList/start
 264 deftype MalList
 265
 266 : here>MalList ( old-here -- mal-list )
 267     here over - { bytes } ( old-here )
 268     MalList new bytes ( old-here mal-list bytes )
 269     allocate throw dup { target } over MalList/start ! ( old-here mal-list )
 270     bytes cell / over MalList/count ! ( old-here mal-list )
 271     swap target bytes cmove ( mal-list )
 272     0 bytes - allot \ pop list contents from dictionary stack
 273     ;
 274
 275 MalList
 276   extend to-list ;;
 277   extend conj { elem old-list -- list }
 278     old-list MalList/count @ 1+ { new-count }
 279     new-count cells allocate throw { new-start }
 280     elem new-start !
 281     new-count 1 > if
 282       old-list MalList/start @   new-start cell+   new-count 1- cells  cmove
 283     endif
 284
 285     MalList new
 286     new-count over MalList/count !
 287     new-start over MalList/start ! ;;
 288   extend empty? MalList/count @ 0= mal-bool ;;
 289   extend mal-count MalList/count @ MalInt. ;;
 290   extend mal=
 291     swap to-list dup 0= if
 292         nip
 293     else
 294         2dup MalList/count @ swap MalList/count @ over = if ( list-a list-b count )
 295             -rot MalList/start @ swap MalList/start @ { start-b start-a }
 296             true swap ( return-val count )
 297             0 ?do
 298                 start-a i cells + @
 299                 start-b i cells + @
 300                 m= if else
 301                     drop false leave
 302                 endif
 303             loop
 304         else
 305             drop 2drop false
 306         endif
 307     endif ;;
 308 drop
 309
 310 MalList new 0 over MalList/count ! constant MalList/Empty
 311
 312 : MalList/rest { list -- list }
 313     MalList new
 314     list MalList/start @   cell+   over MalList/start !
 315     list MalList/count @   1-      over MalList/count ! ;
 316
 317
 318 MalType%
 319   cell% field MalVector/list
 320 deftype MalVector
 321
 322 MalVector
 323   extend to-list
 324     MalVector/list @ ;;
 325   extend empty?
 326     MalVector/list @
 327     MalList/count @ 0= mal-bool ;;
 328   extend mal-count
 329     MalVector/list @
 330     MalList/count @ MalInt. ;;
 331   extend mal=
 332     MalVector/list @ swap m= ;;
 333 drop
 334
 335 MalType%
 336   cell% field MalMap/list
 337 deftype MalMap
 338
 339 MalMap new MalList/Empty over MalMap/list ! constant MalMap/Empty
 340
 341 MalMap
 342   extend conj ( kv map -- map )
 343     MalMap/list @ \ get list
 344     over MalList/start @ cell+ @ swap conj \ add value
 345     swap MalList/start @ @ swap conj \ add key
 346     MalMap new dup -rot MalMap/list ! \ put back in map
 347     ;;
 348   extend assoc ( k v map -- map )
 349     MalMap/list @ \ get list
 350     conj conj
 351     MalMap new dup -rot MalMap/list ! \ put back in map
 352     ;;
 353   extend get { not-found k map -- value }
 354     map MalMap/list @
 355     dup MalList/start @ { start }
 356     MalList/count @ { count }
 357     0
 358     begin
 359         dup count >= if
 360             drop not-found true
 361         else
 362             start over cells + @ k m= if
 363                 start swap cells + cell+ @ true \ found it ( value true )
 364             else
 365                 2 + false
 366             endif
 367         endif
 368     until ;;
 369   extend empty?
 370     MalMap/list @
 371     MalList/count @ 0= mal-bool ;;
 372   extend mal-count
 373     MalMap/list @
 374     MalList/count @ 2 / MalInt. ;;
 375 drop
 376
 377 \ Examples of extending existing protocol methods to existing type
 378 MalDefault
 379   extend conj   ( obj this -- this )
 380     nip ;;
 381   extend as-native ;; ( obj -- obj )
 382   extend to-list drop 0 ;;
 383   extend empty? drop mal-true ;;
 384 drop
 385
 386 MalNil
 387   extend conj ( item nil -- mal-list )
 388     drop MalList/Empty conj ;;
 389   extend as-native drop 0 ;;
 390   extend empty? drop mal-true ;;
 391   extend mal-count drop 0 MalInt. ;;
 392   extend mal= drop mal-nil = ;;
 393 drop
 394
 395 MalType%
 396   cell% field MalSymbol/sym-addr
 397   cell% field MalSymbol/sym-len
 398   cell% field MalSymbol/meta
 399 deftype MalSymbol
 400
 401 : MalSymbol. { str-addr str-len -- mal-sym }
 402     MalSymbol new { sym }
 403     str-addr sym MalSymbol/sym-addr !
 404     str-len  sym MalSymbol/sym-len  !
 405     MalMap/Empty sym MalSymbol/meta  !
 406     sym ;
 407
 408 : unpack-sym ( mal-string -- addr len )
 409     dup MalSymbol/sym-addr @
 410     swap MalSymbol/sym-len @ ;
 411
 412 MalSymbol
 413   extend mal= ( other this -- bool )
 414     over mal-type @ MalSymbol = if
 415         unpack-sym rot unpack-sym str=
 416     else
 417         2drop 0
 418     endif ;;
 419   ' as-native ' unpack-sym extend-method*
 420 drop
 421
 422 MalType%
 423   cell% field MalKeyword/str-addr
 424   cell% field MalKeyword/str-len
 425 deftype MalKeyword
 426
 427 : unpack-keyword ( mal-keyword -- addr len )
 428     dup MalKeyword/str-addr @
 429     swap MalKeyword/str-len @ ;
 430
 431 MalKeyword
 432   extend mal= ( other this -- bool )
 433     over mal-type @ MalKeyword = if
 434         unpack-keyword rot unpack-keyword str=
 435     else
 436         2drop 0
 437     endif ;;
 438   ' as-native ' unpack-keyword extend-method*
 439 drop
 440
 441 : MalKeyword. { str-addr str-len -- mal-keyword }
 442     MalKeyword new { kw }
 443     str-addr kw MalKeyword/str-addr !
 444     str-len  kw MalKeyword/str-len  !
 445     kw ;
 446
 447 MalType%
 448   cell% field MalString/str-addr
 449   cell% field MalString/str-len
 450 deftype MalString
 451
 452 : MalString. { str-addr str-len -- mal-str }
 453     MalString new { str }
 454     str-addr str MalString/str-addr !
 455     str-len  str MalString/str-len  !
 456     str ;
 457
 458 : unpack-str ( mal-string -- addr len )
 459     dup MalString/str-addr @
 460     swap MalString/str-len @ ;
 461
 462 MalString
 463   extend mal= ( other this -- bool )
 464     over mal-type @ MalString = if
 465         unpack-str rot unpack-str str=
 466     else
 467         2drop 0
 468     endif ;;
 469   ' as-native ' unpack-str extend-method*
 470 drop
 471
 472
 473 MalType%
 474   cell% field MalNativeFn/xt
 475   cell% field MalNativeFn/meta
 476 deftype MalNativeFn
 477
 478 : MalNativeFn. { xt -- mal-fn }
 479     MalNativeFn new { mal-fn }
 480     xt mal-fn MalNativeFn/xt !
 481     MalMap/Empty mal-fn MalNativeFn/meta  !
 482     mal-fn ;
 483
 484 MalNativeFn
 485   extend as-native
 486     MalNativeFn/xt @ ;;
 487 drop
 488
 489
 490 MalType%
 491   cell% field MalUserFn/is-macro?
 492   cell% field MalUserFn/env
 493   cell% field MalUserFn/formal-args
 494   cell% field MalUserFn/var-arg
 495   cell% field MalUserFn/body
 496 deftype MalUserFn
 497
 498
 499 MalType%
 500   cell% field SpecialOp/xt
 501 deftype SpecialOp
 502
 503 : SpecialOp.
 504     SpecialOp new swap over SpecialOp/xt ! ;