src/scheme-primitives.4th

   1 \ ==== Type predilcates ==== {{{
   2
   3 :noname ( args -- boolobj )
   4     nil objeq? boolean-type
   5 ; 1 make-fa-primitive null?
   6
   7 :noname ( args -- boolobj )
   8     boolean-type istype? -rot 2drop boolean-type
   9 ; 1 make-fa-primitive boolean?
  10
  11 :noname ( args -- boolobj )
  12     symbol-type istype? -rot 2drop boolean-type
  13 ; 1 make-fa-primitive symbol?
  14
  15 :noname ( args -- boolobj )
  16     fixnum-type istype? -rot 2drop boolean-type
  17 ; 1 make-fa-primitive fixnum?
  18
  19 :noname ( args -- boolobj )
  20     flonum-type istype? -rot 2drop boolean-type
  21 ; 1 make-fa-primitive flonum?
  22
  23 :noname ( args -- boolobj )
  24     ratnum-type istype? -rot 2drop boolean-type
  25 ; 1 make-fa-primitive ratnum?
  26
  27 :noname ( args -- boolobj )
  28     character-type istype? -rot 2drop boolean-type
  29 ; 1 make-fa-primitive char?
  30
  31 :noname ( args -- boolobj )
  32     string-type istype? -rot 2drop boolean-type
  33 ; 1 make-fa-primitive string?
  34
  35 :noname ( args -- boolobj )
  36     pair-type istype? -rot 2drop boolean-type
  37 ; 1 make-fa-primitive pair?
  38
  39 :noname ( args -- boolobj )
  40     primitive-proc-type istype? if
  41         true
  42     else
  43         compound-proc-type istype?
  44     then
  45
  46     -rot 2drop boolean-type
  47 ; 1 make-fa-primitive procedure?
  48
  49 \ }}}
  50
  51 \ ==== Type conversions ==== {{{
  52
  53 :noname ( args -- fixnum )
  54     2dup 1 ensure-arg-count
  55     car character-type ensure-arg-type
  56
  57     drop fixnum-type
  58 ; make-primitive char->integer
  59
  60 :noname ( args -- char )
  61     2dup 1 ensure-arg-count
  62     car fixnum-type ensure-arg-type
  63
  64     drop character-type
  65 ; make-primitive integer->char
  66
  67 : fixnum-to-charlist ( fixnum -- charlist )
  68     over 0= if
  69         2drop
  70         [char] 0 character-type nil cons
  71         exit
  72     then
  73
  74     nil 2swap ( charlist fixnum )
  75
  76     begin
  77         over 0>
  78     while
  79         2dup swap 10 mod swap ( charlist fixnum fixnummod )
  80         2swap swap 10 / swap  ( charlist fixnummod fixnumdiv )
  81         -2rot ( fixnumdiv charlist fixnummod )
  82
  83         drop [char] 0 + character-type 2swap
  84         cons ( fixnumdiv newcharlist )
  85
  86         2swap
  87     repeat
  88
  89     2drop
  90 ;
  91
  92 :noname ( args -- string )
  93     2dup 1 ensure-arg-count
  94     car fixnum-type ensure-arg-type
  95
  96     2dup swap abs swap
  97
  98     fixnum-to-charlist ( fixnum charlist )
  99     2swap drop 0< if
 100         [char] - character-type 2swap cons
 101     then
 102
 103     drop string-type
 104 ; make-primitive number->string
 105
 106 :noname ( args -- symbol )
 107     2dup 1 ensure-arg-count
 108     car string-type ensure-arg-type
 109
 110     drop pair-type
 111
 112     2dup car [char] - character-type objeq? if
 113         cdr
 114         true -rot
 115     else
 116         2dup car [char] + character-type objeq? if
 117             cdr
 118         then
 119         false -rot
 120     then
 121
 122     0 -rot
 123     begin
 124         2dup nil objeq? false =
 125     while
 126         2dup car drop [char] 0 - -rot
 127         2swap swap 10 * + -rot
 128         cdr
 129     repeat
 130
 131     2drop
 132
 133     swap if -1 * then
 134
 135     fixnum-type
 136 ; make-primitive string->number
 137
 138 :noname ( args -- string )
 139     2dup 1 ensure-arg-count
 140     car symbol-type ensure-arg-type
 141
 142     drop pair-type
 143     duplicate-charlist
 144     drop string-type
 145 ; make-primitive symbol->string
 146
 147 :noname ( args -- symbol )
 148     2dup 1 ensure-arg-count
 149     car string-type ensure-arg-type
 150
 151     drop pair-type
 152     duplicate-charlist
 153     charlist>symbol
 154 ; make-primitive string->symbol
 155
 156 :noname ( charlist -- string )
 157     2dup 1 ensure-arg-count
 158
 159     car nil? if
 160         2drop
 161         nil nil cons
 162         drop string-type
 163         exit
 164     then
 165
 166     pair-type ensure-arg-type
 167
 168     duplicate-charlist
 169     drop string-type
 170 ; make-primitive list->string
 171
 172 :noname ( string -- charlist )
 173     2dup 1 ensure-arg-count
 174     car string-type ensure-arg-type
 175
 176     drop pair-type
 177
 178     2dup car nil? if
 179         2swap 2drop
 180     else
 181         2drop
 182         duplicate-charlist
 183     then
 184
 185 ; make-primitive string->list
 186
 187 \ }}}
 188
 189 \ ==== Numeric types ==== {{{
 190
 191 \ --- Fixnums ---
 192
 193 :noname ( fixnum fixnum -- boolobj )
 194     objeq? boolean-type
 195 ; 2 make-fa-primitive fix:=
 196
 197 :noname ( fixnum fixnum -- boolobj )
 198     drop swap drop < boolean-type
 199 ; 2 make-fa-primitive fix:<
 200
 201 :noname ( fixnum fixnum -- boolobj )
 202     drop swap drop > boolean-type
 203 ; 2 make-fa-primitive fix:>
 204
 205 :noname ( fixnum fixnum -- boolobj )
 206     drop swap drop <= boolean-type
 207 ; 2 make-fa-primitive fix:<=
 208
 209 :noname ( fixnum fixnum -- boolobj )
 210     drop swap drop >= boolean-type
 211 ; 2 make-fa-primitive fix:>=
 212
 213 :noname ( fixnum -- boolobj )
 214     drop 0= boolean-type
 215 ; 1 make-fa-primitive fix:zero?
 216
 217 :noname ( fixnum -- boolobj )
 218     drop 0> boolean-type
 219 ; 1 make-fa-primitive fix:positive?
 220
 221 :noname ( fixnum -- boolobj )
 222     drop 0< boolean-type
 223 ; 1 make-fa-primitive fix:negative?
 224
 225 :noname ( fixnum fixnum -- fixnum' )
 226     drop swap drop + fixnum-type
 227 ; 2 make-fa-primitive fix:+
 228
 229 :noname ( fixnum fixnum -- fixnum' )
 230     drop swap drop - fixnum-type
 231 ; 2 make-fa-primitive fix:-
 232
 233 :noname ( fixnum fixnum -- fixnum' )
 234     drop swap drop * fixnum-type
 235 ; 2 make-fa-primitive fix:*
 236
 237 :noname ( fixnum fixnum -- fixnum' )
 238     drop swap drop / fixnum-type
 239 ; 2 make-fa-primitive fix:quotient
 240
 241 :noname ( fixnum fixnum -- fixnum' )
 242     drop swap drop mod fixnum-type
 243 ; 2 make-fa-primitive fix:remainder
 244
 245 :noname ( fixnum -- fixnum+1 )
 246     swap 1+ swap
 247 ; 1 make-fa-primitive fix:1+
 248
 249 :noname ( fixnum -- fixnum-1 )
 250     swap 1- swap
 251 ; 1 make-fa-primitive fix:-1+
 252
 253 :noname ( fixnum -- -fixnum )
 254     swap negate swap
 255 ; 1 make-fa-primitive fix:neg
 256
 257 :noname ( fixnum -- -fixnum )
 258     swap abs swap
 259 ; 1 make-fa-primitive fix:abs
 260
 261 :noname ( fixnum fixnum -- fixnum' )
 262     drop swap drop gcd fixnum-type
 263 ; 2 make-fa-primitive fix:gcd
 264
 265 \ --- Flonums ---
 266
 267 :noname ( flonum flonum -- bool )
 268     objeq? boolean-type
 269 ; 2 make-fa-primitive flo:=
 270
 271 :noname ( flonum flonum -- bool )
 272     drop swap drop f< boolean-type
 273 ; 2 make-fa-primitive flo:<
 274
 275 :noname ( flonum flonum -- bool )
 276     drop swap drop f> boolean-type
 277 ; 2 make-fa-primitive flo:>
 278
 279
 280 :noname ( flonum -- bool )
 281     drop 0.0 = boolean-type
 282 ; 1 make-fa-primitive flo:zero?
 283
 284 :noname ( flonum -- bool )
 285     drop 0.0 f> boolean-type
 286 ; 1 make-fa-primitive flo:positive?
 287
 288 :noname ( flonum -- bool )
 289     drop 0.0 f< boolean-type
 290 ; 1 make-fa-primitive flo:negative?
 291
 292
 293 :noname ( flonum1 flonum2 -- flonum1+flonum2 )
 294     drop swap drop f+ flonum-type
 295 ; 2 make-fa-primitive flo:+
 296
 297 :noname ( flonum1 flonum2 -- flonum1-flonum2 )
 298     drop swap drop f- flonum-type
 299 ; 2 make-fa-primitive flo:-
 300
 301 :noname ( flonum1 flonum2 -- flonum1*flonum2 )
 302     drop swap drop f* flonum-type
 303 ; 2 make-fa-primitive flo:*
 304
 305 :noname ( flonum1 flonum2 -- flonum1/flonum2 )
 306     drop swap drop f/ flonum-type
 307 ; 2 make-fa-primitive flo:/
 308
 309 :noname ( flonum1 flonum2 -- flonum1/flonum2 )
 310     drop swap drop f/ flonum-type
 311 ; 2 make-fa-primitive flo:/
 312
 313
 314 :noname ( flonum -- bool )
 315     drop dup
 316     fnan? swap finf? or invert
 317 ; 1 make-fa-primitive flo:finite?
 318
 319
 320 :noname ( flonum -- flonum )
 321     swap -1.0 f* swap
 322 ; 1 make-fa-primitive flo:neg
 323
 324 :noname ( flonum -- flonum )
 325     swap fabs swap
 326 ; 1 make-fa-primitive flo:abs
 327
 328 :noname ( flonum -- flonum )
 329     swap fexp swap
 330 ; 1 make-fa-primitive flo:exp
 331
 332 :noname ( flonum -- flonum )
 333     swap flog swap
 334 ; 1 make-fa-primitive flo:log
 335
 336 :noname ( flonum -- flonum )
 337     swap fsin swap
 338 ; 1 make-fa-primitive flo:sin
 339
 340 :noname ( flonum -- flonum )
 341     swap fcos swap
 342 ; 1 make-fa-primitive flo:cos
 343
 344 :noname ( flonum -- flonum )
 345     swap ftan swap
 346 ; 1 make-fa-primitive flo:tan
 347
 348 :noname ( flonum -- flonum )
 349     swap fasin swap
 350 ; 1 make-fa-primitive flo:asin
 351
 352 :noname ( flonum -- flonum )
 353     swap facos swap
 354 ; 1 make-fa-primitive flo:acos
 355
 356 :noname ( flonum -- flonum )
 357     swap fatan swap
 358 ; 1 make-fa-primitive flo:atan
 359
 360 :noname ( flonum -- flonum )
 361     swap fsqrt swap
 362 ; 1 make-fa-primitive flo:sqrt
 363
 364 :noname ( flonum flonum -- flonum )
 365     drop swap drop f^ flonum-type
 366 ; 2 make-fa-primitive flo:expt
 367
 368 :noname ( flonum -- flonum )
 369     swap floor swap
 370 ; 1 make-fa-primitive flo:floor
 371
 372 :noname ( flonum -- flonum )
 373     swap ceiling swap
 374 ; 1 make-fa-primitive flo:ceiling
 375
 376 :noname ( flonum -- flonum )
 377     swap truncate swap
 378 ; 1 make-fa-primitive flo:truncate
 379
 380 :noname ( flonum -- flonum )
 381     swap fround swap
 382 ; 1 make-fa-primitive flo:round
 383
 384 :noname ( flonum -- flonum )
 385     drop floor f->i fixnum-type
 386 ; 1 make-fa-primitive flo:floor->exact
 387
 388 :noname ( flonum -- flonum )
 389     drop ceiling f->i fixnum-type
 390 ; 1 make-fa-primitive flo:ceiling->exact
 391
 392 :noname ( flonum -- flonum )
 393     drop truncate f->i fixnum-type
 394 ; 1 make-fa-primitive flo:truncate->exact
 395
 396 :noname ( flonum -- flonum )
 397     drop f->i fixnum-type
 398 ; 1 make-fa-primitive flo:round->exact
 399
 400 :noname ( flonum flonum -- flonum )
 401     drop swap drop f/ fatan flonum-type
 402 ; 2 make-fa-primitive flo:atan2
 403
 404 \ --- Rationals ---
 405
 406 ' make-rational 2 make-fa-primitive make-rational
 407
 408 :noname ( ratnum -- fixnum )
 409     drop pair-type car
 410 ; 1 make-fa-primitive rat:numerator
 411
 412 :noname ( ratnum -- fixnum )
 413     drop pair-type cdr
 414 ; 1 make-fa-primitive rat:denominator
 415
 416 \ --- Conversion ---
 417
 418 :noname ( fixnum -- flonum )
 419     drop i->f flonum-type
 420 ; 1 make-fa-primitive fixnum->flonum
 421
 422 \ }}}
 423
 424 \ ==== Pairs and Lists ==== {{{
 425
 426 :noname ( arg1 arg2 -- pair )
 427     cons
 428 ; 2 make-fa-primitive cons
 429
 430 :noname ( pair-obj -- obj )
 431     car
 432 ; pair-type 1 make-fa-type-primitive car
 433
 434 :noname ( args -- obj )
 435     cdr
 436 ; pair-type 1 make-fa-type-primitive cdr
 437
 438 :noname ( pair obj  -- ok )
 439     2swap pair-type ensure-arg-type
 440
 441     set-car!
 442
 443     ok-symbol
 444 ; 2 make-fa-primitive set-car!
 445
 446 :noname ( pair obj -- ok )
 447     2swap pair-type ensure-arg-type
 448
 449     set-cdr!
 450
 451     ok-symbol
 452 ; 2 make-fa-primitive set-cdr!
 453
 454 \ }}}
 455
 456 \ ==== Polymorphic equality testing ==== {{{
 457
 458 :noname ( arg1 arg2 -- bool )
 459     objeq? boolean-type
 460 ; 2 make-fa-primitive eq?
 461
 462 \ }}}
 463
 464 \ ==== Input/Output ==== {{{
 465
 466 :noname ( -- port )
 467     console-i/o-port obj@
 468 ; 0 make-fa-primitive console-i/o-port
 469
 470 :noname ( -- port )
 471     current-input-port obj@
 472 ; 0 make-fa-primitive current-input-port
 473
 474 : charlist>cstr ( charlist addr -- n )
 475
 476     dup 2swap ( origaddr addr charlist )
 477
 478     begin
 479         nil? false =
 480     while
 481         2dup cdr 2swap car
 482         drop ( origaddr addr charlist char )
 483         -rot 2swap ( origaddr charlist addr char )
 484         over !
 485         1+ -rot ( origaddr nextaddr charlist )
 486     repeat
 487
 488     2drop ( origaddr finaladdr )
 489     swap -
 490 ;
 491
 492 :noname ( args -- finalResult )
 493     drop pair-type
 494     pad charlist>cstr
 495     pad swap load
 496 ; string-type 1 make-fa-type-primitive load
 497
 498 :noname ( args -- obj )
 499     read
 500 ; 0 make-fa-primitive read
 501
 502 defer display
 503
 504 :noname ( obj -- none )
 505     print none
 506 ; 1 make-fa-primitive write
 507
 508 : displaypair ( pairobj -- )
 509     2dup
 510     car display
 511     cdr
 512     nil? if 2drop exit then
 513     pair-type istype? if space recurse exit then
 514     ."  . " display
 515 ;
 516
 517 : displaychar ( charobj -- )
 518     drop emit ;
 519
 520 : (displaystring) ( charlist -- )
 521     nil? if
 522         2drop
 523     else
 524         2dup car displaychar
 525         cdr recurse
 526     then
 527 ;
 528
 529 : displaystring ( stringobj -- )
 530     drop pair-type (displaystring)
 531 ;
 532
 533 :noname ( obj -- )
 534     pair-type istype? if ." (" displaypair ." )" exit then
 535     character-type istype? if displaychar exit then
 536     string-type istype? if displaystring exit then
 537
 538     print
 539 ; is display
 540
 541 :noname ( stringobj -- none )
 542     displaystring none
 543 ; string-type 1 make-fa-type-primitive display-string
 544
 545 :noname ( charobj -- none )
 546     displaychar none
 547 ; character-type 1 make-fa-type-primitive display-character
 548
 549 :noname ( obj -- none )
 550     display none
 551 ; 1 make-fa-primitive display
 552
 553 :noname ( args -- none )
 554     cr none
 555 ; 0 make-fa-primitive newline
 556
 557 \ }}}
 558
 559 \ ==== Evaluation ==== {{{
 560
 561 :noname ( args -- result )
 562     2dup car 2swap cdr
 563
 564     nil? false = if car then ( proc argvals )
 565
 566     apply
 567 ; make-primitive apply
 568
 569 \ }}}
 570
 571 \ ==== Miscellaneous  ==== {{{
 572
 573 ( Produce a recoverable exception. )
 574 :noname ( args -- result )
 575     bold fg red
 576
 577     nil? if
 578         ." Error."
 579     else
 580         ." Error: " car display
 581     then
 582
 583     reset-term
 584
 585     recoverable-exception throw
 586 ; make-primitive error
 587
 588 ( Generate a temporary unique symbol. Used in the creation of hygienic macros. )
 589 :noname ( args -- result )
 590     [char] _  character-type nil cons
 591     drop symbol-type
 592 ; 0 make-fa-primitive gensym
 593
 594 ( Generate the NONE object indicating an unspecified return value. )
 595 :noname ( args -- result )
 596     none
 597 ; 0 make-fa-primitive none
 598
 599 \ }}}
 600
 601 \ vim:fdm=marker