scheme-primitives.4th

   1 \ ==== Type predicates ==== {{{
   2
   3 :noname ( args -- boolobj )
   4     2dup 1 ensure-arg-count
   5
   6     car nil objeq? boolean-type
   7 ; make-primitive null?
   8
   9 :noname ( args -- boolobj )
  10     2dup 1 ensure-arg-count
  11
  12     car boolean-type istype? -rot 2drop boolean-type
  13 ; make-primitive boolean?
  14
  15 :noname ( args -- boolobj )
  16     2dup 1 ensure-arg-count
  17
  18     car symbol-type istype? -rot 2drop boolean-type
  19 ; make-primitive symbol?
  20
  21 :noname ( args -- boolobj )
  22     2dup 1 ensure-arg-count
  23
  24     car fixnum-type istype? -rot 2drop boolean-type
  25 ; make-primitive integer?
  26
  27 :noname ( args -- boolobj )
  28     2dup 1 ensure-arg-count
  29
  30     car character-type istype? -rot 2drop boolean-type
  31 ; make-primitive char?
  32
  33 :noname ( args -- boolobj )
  34     2dup 1 ensure-arg-count
  35
  36     car string-type istype? -rot 2drop boolean-type
  37 ; make-primitive string?
  38
  39 :noname ( args -- boolobj )
  40     2dup 1 ensure-arg-count
  41
  42     car pair-type istype? -rot 2drop boolean-type
  43 ; make-primitive pair?
  44
  45 :noname ( args -- boolobj )
  46     2dup 1 ensure-arg-count
  47
  48     car primitive-proc-type istype? -rot 2drop boolean-type
  49 ; make-primitive procedure?
  50
  51 \ }}}
  52
  53 \ ==== Type conversions ==== {{{
  54
  55 :noname ( args -- fixnum )
  56     2dup 1 ensure-arg-count
  57     car character-type ensure-arg-type
  58
  59     drop fixnum-type
  60 ; make-primitive char->integer
  61
  62 :noname ( args -- char )
  63     2dup 1 ensure-arg-count
  64     car fixnum-type ensure-arg-type
  65
  66     drop character-type
  67 ; make-primitive integer->char
  68
  69 : fixnum-to-charlist ( fixnum -- charlist )
  70     over 0= if
  71         2drop
  72         [char] 0 character-type nil cons
  73         exit
  74     then
  75
  76     nil 2swap ( charlist fixnum )
  77
  78     begin
  79         over 0>
  80     while
  81         2dup swap 10 mod swap ( charlist fixnum fixnummod )
  82         2swap swap 10 / swap  ( charlist fixnummod fixnumdiv )
  83         -2rot ( fixnumdiv charlist fixnummod )
  84
  85         drop [char] 0 + character-type 2swap
  86         cons ( fixnumdiv newcharlist )
  87
  88         2swap
  89     repeat
  90
  91     2drop
  92 ;
  93
  94 :noname ( args -- string )
  95     2dup 1 ensure-arg-count
  96     car fixnum-type ensure-arg-type
  97
  98     2dup swap abs swap
  99
 100     fixnum-to-charlist ( fixnum charlist )
 101     2swap drop 0< if
 102         [char] - character-type 2swap cons
 103     then
 104
 105     drop string-type
 106 ; make-primitive number->string
 107
 108 :noname ( args -- symbol )
 109     2dup 1 ensure-arg-count
 110     car string-type ensure-arg-type
 111
 112     drop pair-type
 113
 114     2dup car [char] - character-type objeq? if
 115         cdr
 116         true -rot
 117     else
 118         2dup car [char] + character-type objeq? if
 119             cdr
 120         then
 121         false -rot
 122     then
 123
 124     0 -rot
 125     begin
 126         2dup nil objeq? false =
 127     while
 128         2dup car drop [char] 0 - -rot
 129         2swap swap 10 * + -rot
 130         cdr
 131     repeat
 132
 133     2drop
 134
 135     swap if -1 * then
 136
 137     fixnum-type
 138 ; make-primitive string->number
 139
 140 :noname ( args -- string )
 141     2dup 1 ensure-arg-count
 142     car symbol-type ensure-arg-type
 143
 144     drop pair-type
 145     duplicate-charlist
 146     drop string-type
 147 ; make-primitive symbol->string
 148
 149 :noname ( args -- symbol )
 150     2dup 1 ensure-arg-count
 151     car string-type ensure-arg-type
 152
 153     drop pair-type
 154     duplicate-charlist
 155     charlist>symbol
 156 ; make-primitive string->symbol
 157
 158 \ }}}
 159
 160 \ ==== Arithmetic ==== {{{
 161
 162 : add-prim ( args -- fixnum )
 163     2dup nil objeq? if
 164         2drop
 165         0 fixnum-type
 166     else
 167         2dup car drop
 168         -rot cdr recurse drop
 169         + fixnum-type
 170     then
 171 ;
 172 ' add-prim make-primitive +
 173
 174 :noname ( args -- fixnum )
 175     2dup nil objeq? if
 176         2drop
 177         0 fixnum-type
 178     else
 179         2dup car drop
 180         -rot cdr
 181         2dup nil objeq? if
 182             2drop negate
 183         else
 184             add-prim drop
 185             -
 186         then
 187         fixnum-type
 188     then
 189 ; make-primitive -
 190
 191 :noname ( args -- fixnum )
 192     2dup nil objeq? if
 193         2drop
 194         1 fixnum-type
 195     else
 196         2dup car drop
 197         -rot cdr recurse drop
 198         * fixnum-type
 199     then
 200 ; make-primitive *
 201
 202 :noname ( args -- fixnum )
 203     2dup 2 ensure-arg-count
 204
 205     2dup car fixnum-type ensure-arg-type
 206     2swap cdr car fixnum-type ensure-arg-type
 207
 208     drop swap drop
 209
 210     / fixnum-type
 211 ; make-primitive quotient
 212
 213 :noname ( args -- fixnum )
 214     2dup 2 ensure-arg-count
 215
 216     2dup car fixnum-type ensure-arg-type
 217     2swap cdr car fixnum-type ensure-arg-type
 218
 219     drop swap drop
 220
 221     mod fixnum-type
 222 ; make-primitive remainder
 223
 224 variable relcfa
 225
 226 : test-relation ( args -- bool )
 227
 228     2dup nil objeq? if
 229         2drop
 230         true boolean-type exit
 231     then
 232
 233     ( args )
 234
 235     2dup car fixnum-type ensure-arg-type ( args arg0 )
 236     2swap cdr ( arg0 args' )
 237
 238     2dup nil objeq? if
 239         2drop 2drop
 240         true boolean-type exit
 241     then
 242
 243     ( arg0 args' )
 244
 245     begin
 246         2dup nil objeq? false =
 247     while
 248         2dup car fixnum-type ensure-arg-type ( arg0 args' arg1 )
 249         2rot 2swap 2dup 2rot 2swap ( args' arg1 arg1 arg0 )
 250         relcfa @ execute false = if
 251             2drop 2drop
 252             false boolean-type exit
 253         then
 254
 255         2swap cdr ( arg0 args'' )
 256     repeat
 257
 258     2drop 2drop
 259     true boolean-type
 260 ;
 261
 262 : fixnum-lt ( obj1 obj2 -- bool )
 263     drop swap drop <
 264 ;
 265
 266 :noname
 267     ['] fixnum-lt relcfa !
 268     test-relation
 269 ; make-primitive <
 270
 271 : fixnum-gt ( obj1 obj2 -- bool )
 272     drop swap drop >
 273 ;
 274
 275 :noname
 276     ['] fixnum-gt relcfa !
 277     test-relation
 278 ; make-primitive >
 279
 280 : fixnum-eq ( obj1 obj2 -- bool )
 281     drop swap drop =
 282 ;
 283
 284 :noname
 285     ['] fixnum-eq relcfa !
 286     test-relation
 287 ; make-primitive =
 288
 289 hide relcfa
 290
 291 \ }}}
 292
 293 \ ==== Pairs and Lists ==== {{{
 294
 295 :noname ( args -- pair )
 296     2dup 2 ensure-arg-count
 297
 298     2dup car 2swap cdr car
 299     cons
 300 ; make-primitive cons
 301
 302 :noname ( args -- list )
 303     \ args is already a list!
 304 ; make-primitive list
 305
 306 :noname ( args -- obj )
 307     2dup 1 ensure-arg-count
 308     car pair-type ensure-arg-type
 309
 310     car
 311 ; make-primitive car
 312
 313 :noname ( args -- obj )
 314     2dup 1 ensure-arg-count
 315     car pair-type ensure-arg-type
 316
 317     cdr
 318 ; make-primitive cdr
 319
 320 :noname ( args -- ok )
 321     2dup 2 ensure-arg-count
 322     2dup cdr car
 323     2swap car pair-type ensure-arg-type
 324
 325     set-car!
 326
 327     ok-symbol
 328 ; make-primitive set-car!
 329
 330 :noname ( args -- ok )
 331     2dup 2 ensure-arg-count
 332     2dup cdr car
 333     2swap car pair-type ensure-arg-type
 334
 335     set-cdr!
 336
 337     ok-symbol
 338 ; make-primitive set-cdr!
 339
 340 \ }}}
 341
 342 \ ==== Polymorphic equality testing ==== {{{
 343
 344 :noname ( args -- bool )
 345     2dup 2 ensure-arg-count
 346     2dup cdr car
 347     2swap car
 348
 349     objeq? boolean-type
 350 ; make-primitive eq?
 351
 352 \ }}}
 353
 354 \ ==== Input/Output ==== {{{
 355
 356 :noname ( args -- finalResult )
 357     2dup 1 ensure-arg-count
 358     car string-type ensure-arg-type
 359
 360     drop pair-type
 361     pad charlist>cstr
 362     pad swap load
 363 ; make-primitive load
 364
 365 :noname ( args -- obj )
 366     0 ensure-arg-count
 367     read
 368 ; make-primitive read
 369
 370 defer display
 371 :noname ( args -- none )
 372     2dup 1 ensure-arg-count
 373
 374     car print
 375
 376     none
 377 ; make-primitive write
 378
 379 : displaypair ( pairobj -- )
 380     2dup
 381     car display
 382     cdr
 383     nil? if 2drop exit then
 384     pair-type istype? if space recurse exit then
 385     ."  . " display
 386 ;
 387
 388 : displaychar ( charobj -- )
 389     drop emit ;
 390
 391 : (displaystring) ( charlist -- )
 392     nil? if
 393         2drop
 394     else
 395         2dup car displaychar
 396         cdr recurse
 397     then
 398 ;
 399
 400 : displaystring ( stringobj -- )
 401     drop pair-type (displaystring)
 402 ;
 403
 404 :noname ( obj -- )
 405     pair-type istype? if ." (" displaypair ." )" exit then
 406     character-type istype? if displaychar exit then
 407     string-type istype? if displaystring exit then
 408
 409     print
 410 ; is display
 411
 412 :noname ( args -- none )
 413     2dup 1 ensure-arg-count
 414     car string-type ensure-arg-type
 415
 416     displaystring
 417
 418     none
 419 ; make-primitive display-string
 420
 421 :noname ( args -- none )
 422     2dup 1 ensure-arg-count
 423     car character-type ensure-arg-type
 424
 425     displaychar
 426
 427     none
 428 ; make-primitive display-character
 429
 430 :noname ( args -- none )
 431     2dup 1 ensure-arg-count
 432     car
 433
 434     display
 435
 436     none
 437 ; make-primitive display
 438
 439 :noname ( args -- none )
 440     0 ensure-arg-count
 441
 442     cr
 443
 444     none
 445 ; make-primitive newline
 446
 447 \ }}}
 448
 449 \ ==== Evaluation ==== {{{
 450
 451 :noname ( args -- result )
 452     2dup car 2swap cdr
 453
 454     nil? false = if car then ( proc argvals )
 455
 456     apply
 457 ; make-primitive apply
 458
 459 \ }}}
 460
 461 \ ==== Miscellaneous  ==== {{{
 462
 463 ( Produce a recoverable exception. )
 464 :noname ( args -- result )
 465     bold fg red
 466
 467     nil? if
 468         ." Error."
 469     else
 470         ." Error: " car display
 471     then
 472
 473     reset-term
 474
 475     recoverable-exception throw
 476 ; make-primitive error
 477
 478 ( Generate a temporary unique symbol. Used in the creation of hygienic macros. )
 479 :noname ( args -- result )
 480     0 ensure-arg-count
 481
 482     [char] _  character-type nil cons
 483     drop symbol-type
 484 ; make-primitive gensym
 485
 486 \ }}}
 487
 488 \ vim:fdm=marker