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 \ ==== Primitivle Arithmetic ==== {{{
 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 fabs swap
 284 ; 1 make-fa-primitive flo:abs
 285
 286 :noname ( flonum -- flonum )
 287     swap fexp swap
 288 ; 1 make-fa-primitive flo:exp
 289
 290 :noname ( flonum -- flonum )
 291     swap flog swap
 292 ; 1 make-fa-primitive flo:log
 293
 294 :noname ( flonum -- flonum )
 295     swap fsin swap
 296 ; 1 make-fa-primitive flo:sin
 297
 298 :noname ( flonum -- flonum )
 299     swap fcos swap
 300 ; 1 make-fa-primitive flo:cos
 301
 302 :noname ( flonum -- flonum )
 303     swap ftan swap
 304 ; 1 make-fa-primitive flo:tan
 305
 306 :noname ( flonum -- flonum )
 307     swap fasin swap
 308 ; 1 make-fa-primitive flo:asin
 309
 310 :noname ( flonum -- flonum )
 311     swap facos swap
 312 ; 1 make-fa-primitive flo:acos
 313
 314 :noname ( flonum -- flonum )
 315     swap fatan swap
 316 ; 1 make-fa-primitive flo:atan
 317
 318 :noname ( flonum -- flonum )
 319     swap fsqrt swap
 320 ; 1 make-fa-primitive flo:sqrt
 321
 322 :noname ( flonum flonum -- flonum )
 323     drop swap drop f^ flonum-type
 324 ; 2 make-fa-primitive flo:expt
 325
 326 :noname ( flonum -- flonum )
 327     swap floor swap
 328 ; 1 make-fa-primitive flo:floor
 329
 330 :noname ( flonum -- flonum )
 331     swap ceiling swap
 332 ; 1 make-fa-primitive flo:ceiling
 333
 334 :noname ( flonum -- flonum )
 335     swap truncate swap
 336 ; 1 make-fa-primitive flo:truncate
 337
 338 :noname ( flonum -- flonum )
 339     swap fround swap
 340 ; 1 make-fa-primitive flo:round
 341
 342 :noname ( flonum -- flonum )
 343     drop floor f->i fixnum-type
 344 ; 1 make-fa-primitive flo:floor->exact
 345
 346 :noname ( flonum -- flonum )
 347     drop ceiling f->i fixnum-type
 348 ; 1 make-fa-primitive flo:ceiling->exact
 349
 350 :noname ( flonum -- flonum )
 351     drop truncate f->i fixnum-type
 352 ; 1 make-fa-primitive flo:truncate->exact
 353
 354 :noname ( flonum -- flonum )
 355     drop f->i fixnum-type
 356 ; 1 make-fa-primitive flo:round->exact
 357
 358 :noname ( flonum flonum -- flonum )
 359     drop swap drop f/ fatan flonum-type
 360 ; 2 make-fa-primitive flo:atan2
 361
 362 \ }}}
 363
 364 \ ==== Pairs and Lists ==== {{{
 365
 366 :noname ( arg1 arg2 -- pair )
 367     cons
 368 ; 2 make-fa-primitive cons
 369
 370 :noname ( pair-obj -- obj )
 371     car
 372 ; pair-type 1 make-fa-type-primitive car
 373
 374 :noname ( args -- obj )
 375     cdr
 376 ; pair-type 1 make-fa-type-primitive cdr
 377
 378 :noname ( pair obj  -- ok )
 379     2swap pair-type ensure-arg-type
 380
 381     set-car!
 382
 383     ok-symbol
 384 ; 2 make-fa-primitive set-car!
 385
 386 :noname ( pair obj -- ok )
 387     2swap pair-type ensure-arg-type
 388
 389     set-cdr!
 390
 391     ok-symbol
 392 ; 2 make-fa-primitive set-cdr!
 393
 394 \ }}}
 395
 396 \ ==== Polymorphic equality testing ==== {{{
 397
 398 :noname ( arg1 arg2 -- bool )
 399     objeq? boolean-type
 400 ; 2 make-fa-primitive eq?
 401
 402 \ }}}
 403
 404 \ ==== Input/Output ==== {{{
 405
 406 :noname ( args -- finalResult )
 407     drop pair-type
 408     pad charlist>cstr
 409     pad swap load
 410 ; string-type 1 make-fa-type-primitive load
 411
 412 :noname ( args -- obj )
 413     read
 414 ; 0 make-fa-primitive read
 415
 416 defer display
 417
 418 :noname ( obj -- none )
 419     print none
 420 ; 1 make-fa-primitive write
 421
 422 : displaypair ( pairobj -- )
 423     2dup
 424     car display
 425     cdr
 426     nil? if 2drop exit then
 427     pair-type istype? if space recurse exit then
 428     ."  . " display
 429 ;
 430
 431 : displaychar ( charobj -- )
 432     drop emit ;
 433
 434 : (displaystring) ( charlist -- )
 435     nil? if
 436         2drop
 437     else
 438         2dup car displaychar
 439         cdr recurse
 440     then
 441 ;
 442
 443 : displaystring ( stringobj -- )
 444     drop pair-type (displaystring)
 445 ;
 446
 447 :noname ( obj -- )
 448     pair-type istype? if ." (" displaypair ." )" exit then
 449     character-type istype? if displaychar exit then
 450     string-type istype? if displaystring exit then
 451
 452     print
 453 ; is display
 454
 455 :noname ( stringobj -- none )
 456     displaystring none
 457 ; string-type 1 make-fa-type-primitive display-string
 458
 459 :noname ( charobj -- none )
 460     displaychar none
 461 ; character-type 1 make-fa-type-primitive display-character
 462
 463 :noname ( obj -- none )
 464     display none
 465 ; 1 make-fa-primitive display
 466
 467 :noname ( args -- none )
 468     cr none
 469 ; 0 make-fa-primitive newline
 470
 471 \ }}}
 472
 473 \ ==== Evaluation ==== {{{
 474
 475 :noname ( args -- result )
 476     2dup car 2swap cdr
 477
 478     nil? false = if car then ( proc argvals )
 479
 480     apply
 481 ; make-primitive apply
 482
 483 \ }}}
 484
 485 \ ==== Miscellaneous  ==== {{{
 486
 487 ( Produce a recoverable exception. )
 488 :noname ( args -- result )
 489     bold fg red
 490
 491     nil? if
 492         ." Error."
 493     else
 494         ." Error: " car display
 495     then
 496
 497     reset-term
 498
 499     recoverable-exception throw
 500 ; make-primitive error
 501
 502 ( Generate a temporary unique symbol. Used in the creation of hygienic macros. )
 503 :noname ( args -- result )
 504     [char] _  character-type nil cons
 505     drop symbol-type
 506 ; 0 make-fa-primitive gensym
 507
 508 ( Generate the NONE object indicating an unspecified return value. )
 509 :noname ( args -- result )
 510     none
 511 ; 0 make-fa-primitive none
 512
 513 \ }}}
 514
 515 \ vim:fdm=marker