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