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