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 \ }}}
 157
 158 \ ==== Numeric types ==== {{{
 159
 160 \ --- Fixnums ---
 161
 162 :noname ( fixnum fixnum -- boolobj )
 163     objeq? boolean-type
 164 ; 2 make-fa-primitive fix:=
 165
 166 :noname ( fixnum fixnum -- boolobj )
 167     drop swap drop < boolean-type
 168 ; 2 make-fa-primitive fix:<
 169
 170 :noname ( fixnum fixnum -- boolobj )
 171     drop swap drop > boolean-type
 172 ; 2 make-fa-primitive fix:>
 173
 174 :noname ( fixnum fixnum -- boolobj )
 175     drop swap drop <= boolean-type
 176 ; 2 make-fa-primitive fix:<=
 177
 178 :noname ( fixnum fixnum -- boolobj )
 179     drop swap drop >= boolean-type
 180 ; 2 make-fa-primitive fix:>=
 181
 182 :noname ( fixnum -- boolobj )
 183     drop 0= boolean-type
 184 ; 1 make-fa-primitive fix:zero?
 185
 186 :noname ( fixnum -- boolobj )
 187     drop 0> boolean-type
 188 ; 1 make-fa-primitive fix:positive?
 189
 190 :noname ( fixnum -- boolobj )
 191     drop 0< boolean-type
 192 ; 1 make-fa-primitive fix:negative?
 193
 194 :noname ( fixnum fixnum -- fixnum' )
 195     drop swap drop + fixnum-type
 196 ; 2 make-fa-primitive fix:+
 197
 198 :noname ( fixnum fixnum -- fixnum' )
 199     drop swap drop - fixnum-type
 200 ; 2 make-fa-primitive fix:-
 201
 202 :noname ( fixnum fixnum -- fixnum' )
 203     drop swap drop * fixnum-type
 204 ; 2 make-fa-primitive fix:*
 205
 206 :noname ( fixnum fixnum -- fixnum' )
 207     drop swap drop / fixnum-type
 208 ; 2 make-fa-primitive fix:quotient
 209
 210 :noname ( fixnum fixnum -- fixnum' )
 211     drop swap drop mod fixnum-type
 212 ; 2 make-fa-primitive fix:remainder
 213
 214 :noname ( fixnum -- fixnum+1 )
 215     swap 1+ swap
 216 ; 1 make-fa-primitive fix:1+
 217
 218 :noname ( fixnum -- fixnum-1 )
 219     swap 1- swap
 220 ; 1 make-fa-primitive fix:-1+
 221
 222 :noname ( fixnum -- -fixnum )
 223     swap negate swap
 224 ; 1 make-fa-primitive fix:neg
 225
 226 :noname ( fixnum -- -fixnum )
 227     swap abs swap
 228 ; 1 make-fa-primitive fix:abs
 229
 230 :noname ( fixnum fixnum -- fixnum' )
 231     drop swap drop gcd fixnum-type
 232 ; 2 make-fa-primitive fix:gcd
 233
 234 \ --- Flonums ---
 235
 236 :noname ( flonum flonum -- bool )
 237     objeq? boolean-type
 238 ; 2 make-fa-primitive flo:=
 239
 240 :noname ( flonum flonum -- bool )
 241     drop swap drop f< boolean-type
 242 ; 2 make-fa-primitive flo:<
 243
 244 :noname ( flonum flonum -- bool )
 245     drop swap drop f> boolean-type
 246 ; 2 make-fa-primitive flo:>
 247
 248
 249 :noname ( flonum -- bool )
 250     drop 0.0 = boolean-type
 251 ; 1 make-fa-primitive flo:zero?
 252
 253 :noname ( flonum -- bool )
 254     drop 0.0 f> boolean-type
 255 ; 1 make-fa-primitive flo:positive?
 256
 257 :noname ( flonum -- bool )
 258     drop 0.0 f< boolean-type
 259 ; 1 make-fa-primitive flo:negative?
 260
 261
 262 :noname ( flonum1 flonum2 -- flonum1+flonum2 )
 263     drop swap drop f+ flonum-type
 264 ; 2 make-fa-primitive flo:+
 265
 266 :noname ( flonum1 flonum2 -- flonum1-flonum2 )
 267     drop swap drop f- flonum-type
 268 ; 2 make-fa-primitive flo:-
 269
 270 :noname ( flonum1 flonum2 -- flonum1*flonum2 )
 271     drop swap drop f* flonum-type
 272 ; 2 make-fa-primitive flo:*
 273
 274 :noname ( flonum1 flonum2 -- flonum1/flonum2 )
 275     drop swap drop f/ flonum-type
 276 ; 2 make-fa-primitive flo:/
 277
 278 :noname ( flonum1 flonum2 -- flonum1/flonum2 )
 279     drop swap drop f/ flonum-type
 280 ; 2 make-fa-primitive flo:/
 281
 282
 283 :noname ( flonum -- bool )
 284     drop dup
 285     fnan? swap finf? or invert
 286 ; 1 make-fa-primitive flo:finite?
 287
 288
 289 :noname ( flonum -- flonum )
 290     swap -1.0 f* swap
 291 ; 1 make-fa-primitive flo:neg
 292
 293 :noname ( flonum -- flonum )
 294     swap fabs swap
 295 ; 1 make-fa-primitive flo:abs
 296
 297 :noname ( flonum -- flonum )
 298     swap fexp swap
 299 ; 1 make-fa-primitive flo:exp
 300
 301 :noname ( flonum -- flonum )
 302     swap flog swap
 303 ; 1 make-fa-primitive flo:log
 304
 305 :noname ( flonum -- flonum )
 306     swap fsin swap
 307 ; 1 make-fa-primitive flo:sin
 308
 309 :noname ( flonum -- flonum )
 310     swap fcos swap
 311 ; 1 make-fa-primitive flo:cos
 312
 313 :noname ( flonum -- flonum )
 314     swap ftan swap
 315 ; 1 make-fa-primitive flo:tan
 316
 317 :noname ( flonum -- flonum )
 318     swap fasin swap
 319 ; 1 make-fa-primitive flo:asin
 320
 321 :noname ( flonum -- flonum )
 322     swap facos swap
 323 ; 1 make-fa-primitive flo:acos
 324
 325 :noname ( flonum -- flonum )
 326     swap fatan swap
 327 ; 1 make-fa-primitive flo:atan
 328
 329 :noname ( flonum -- flonum )
 330     swap fsqrt swap
 331 ; 1 make-fa-primitive flo:sqrt
 332
 333 :noname ( flonum flonum -- flonum )
 334     drop swap drop f^ flonum-type
 335 ; 2 make-fa-primitive flo:expt
 336
 337 :noname ( flonum -- flonum )
 338     swap floor swap
 339 ; 1 make-fa-primitive flo:floor
 340
 341 :noname ( flonum -- flonum )
 342     swap ceiling swap
 343 ; 1 make-fa-primitive flo:ceiling
 344
 345 :noname ( flonum -- flonum )
 346     swap truncate swap
 347 ; 1 make-fa-primitive flo:truncate
 348
 349 :noname ( flonum -- flonum )
 350     swap fround swap
 351 ; 1 make-fa-primitive flo:round
 352
 353 :noname ( flonum -- flonum )
 354     drop floor f->i fixnum-type
 355 ; 1 make-fa-primitive flo:floor->exact
 356
 357 :noname ( flonum -- flonum )
 358     drop ceiling f->i fixnum-type
 359 ; 1 make-fa-primitive flo:ceiling->exact
 360
 361 :noname ( flonum -- flonum )
 362     drop truncate f->i fixnum-type
 363 ; 1 make-fa-primitive flo:truncate->exact
 364
 365 :noname ( flonum -- flonum )
 366     drop f->i fixnum-type
 367 ; 1 make-fa-primitive flo:round->exact
 368
 369 :noname ( flonum flonum -- flonum )
 370     drop swap drop f/ fatan flonum-type
 371 ; 2 make-fa-primitive flo:atan2
 372
 373 \ --- Rationals ---
 374
 375 ' make-rational 2 make-fa-primitive make-rational
 376
 377 :noname ( ratnum -- fixnum )
 378     drop pair-type car
 379 ; 1 make-fa-primitive rat:numerator
 380
 381 :noname ( ratnum -- fixnum )
 382     drop pair-type cdr
 383 ; 1 make-fa-primitive rat:denominator
 384
 385 \ --- Conversion ---
 386
 387 :noname ( fixnum -- flonum )
 388     drop i->f flonum-type
 389 ; 1 make-fa-primitive fixnum->flonum
 390
 391 \ }}}
 392
 393 \ ==== Pairs and Lists ==== {{{
 394
 395 :noname ( arg1 arg2 -- pair )
 396     cons
 397 ; 2 make-fa-primitive cons
 398
 399 :noname ( pair-obj -- obj )
 400     car
 401 ; pair-type 1 make-fa-type-primitive car
 402
 403 :noname ( args -- obj )
 404     cdr
 405 ; pair-type 1 make-fa-type-primitive cdr
 406
 407 :noname ( pair obj  -- ok )
 408     2swap pair-type ensure-arg-type
 409
 410     set-car!
 411
 412     ok-symbol
 413 ; 2 make-fa-primitive set-car!
 414
 415 :noname ( pair obj -- ok )
 416     2swap pair-type ensure-arg-type
 417
 418     set-cdr!
 419
 420     ok-symbol
 421 ; 2 make-fa-primitive set-cdr!
 422
 423 \ }}}
 424
 425 \ ==== Polymorphic equality testing ==== {{{
 426
 427 :noname ( arg1 arg2 -- bool )
 428     objeq? boolean-type
 429 ; 2 make-fa-primitive eq?
 430
 431 \ }}}
 432
 433 \ ==== Input/Output ==== {{{
 434
 435 :noname ( args -- finalResult )
 436     drop pair-type
 437     pad charlist>cstr
 438     pad swap load
 439 ; string-type 1 make-fa-type-primitive load
 440
 441 :noname ( args -- obj )
 442     read
 443 ; 0 make-fa-primitive read
 444
 445 defer display
 446
 447 :noname ( obj -- none )
 448     print none
 449 ; 1 make-fa-primitive write
 450
 451 : displaypair ( pairobj -- )
 452     2dup
 453     car display
 454     cdr
 455     nil? if 2drop exit then
 456     pair-type istype? if space recurse exit then
 457     ."  . " display
 458 ;
 459
 460 : displaychar ( charobj -- )
 461     drop emit ;
 462
 463 : (displaystring) ( charlist -- )
 464     nil? if
 465         2drop
 466     else
 467         2dup car displaychar
 468         cdr recurse
 469     then
 470 ;
 471
 472 : displaystring ( stringobj -- )
 473     drop pair-type (displaystring)
 474 ;
 475
 476 :noname ( obj -- )
 477     pair-type istype? if ." (" displaypair ." )" exit then
 478     character-type istype? if displaychar exit then
 479     string-type istype? if displaystring exit then
 480
 481     print
 482 ; is display
 483
 484 :noname ( stringobj -- none )
 485     displaystring none
 486 ; string-type 1 make-fa-type-primitive display-string
 487
 488 :noname ( charobj -- none )
 489     displaychar none
 490 ; character-type 1 make-fa-type-primitive display-character
 491
 492 :noname ( obj -- none )
 493     display none
 494 ; 1 make-fa-primitive display
 495
 496 :noname ( args -- none )
 497     cr none
 498 ; 0 make-fa-primitive newline
 499
 500 \ }}}
 501
 502 \ ==== Evaluation ==== {{{
 503
 504 :noname ( args -- result )
 505     2dup car 2swap cdr
 506
 507     nil? false = if car then ( proc argvals )
 508
 509     apply
 510 ; make-primitive apply
 511
 512 \ }}}
 513
 514 \ ==== Miscellaneous  ==== {{{
 515
 516 ( Produce a recoverable exception. )
 517 :noname ( args -- result )
 518     bold fg red
 519
 520     nil? if
 521         ." Error."
 522     else
 523         ." Error: " car display
 524     then
 525
 526     reset-term
 527
 528     recoverable-exception throw
 529 ; make-primitive error
 530
 531 ( Generate a temporary unique symbol. Used in the creation of hygienic macros. )
 532 :noname ( args -- result )
 533     [char] _  character-type nil cons
 534     drop symbol-type
 535 ; 0 make-fa-primitive gensym
 536
 537 ( Generate the NONE object indicating an unspecified return value. )
 538 :noname ( args -- result )
 539     none
 540 ; 0 make-fa-primitive none
 541
 542 \ }}}
 543
 544 \ vim:fdm=marker