src/scheme-primitives.4th

   1 \ ==== Type predicates ==== {{{
   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     character-type istype? -rot 2drop boolean-type
  21 ; 1 make-fa-primitive char?
  22
  23 :noname ( args -- boolobj )
  24     string-type istype? -rot 2drop boolean-type
  25 ; 1 make-fa-primitive string?
  26
  27 :noname ( args -- boolobj )
  28     pair-type istype? -rot 2drop boolean-type
  29 ; 1 make-fa-primitive pair?
  30
  31 :noname ( args -- boolobj )
  32     primitive-proc-type istype? if
  33         true
  34     else
  35         compound-proc-type istype?
  36     then
  37
  38     -rot 2drop boolean-type
  39 ; 1 make-fa-primitive procedure?
  40
  41 \ }}}
  42
  43 \ ==== Type conversions ==== {{{
  44
  45 :noname ( args -- fixnum )
  46     2dup 1 ensure-arg-count
  47     car character-type ensure-arg-type
  48
  49     drop fixnum-type
  50 ; make-primitive char->integer
  51
  52 :noname ( args -- char )
  53     2dup 1 ensure-arg-count
  54     car fixnum-type ensure-arg-type
  55
  56     drop character-type
  57 ; make-primitive integer->char
  58
  59 : fixnum-to-charlist ( fixnum -- charlist )
  60     over 0= if
  61         2drop
  62         [char] 0 character-type nil cons
  63         exit
  64     then
  65
  66     nil 2swap ( charlist fixnum )
  67
  68     begin
  69         over 0>
  70     while
  71         2dup swap 10 mod swap ( charlist fixnum fixnummod )
  72         2swap swap 10 / swap  ( charlist fixnummod fixnumdiv )
  73         -2rot ( fixnumdiv charlist fixnummod )
  74
  75         drop [char] 0 + character-type 2swap
  76         cons ( fixnumdiv newcharlist )
  77
  78         2swap
  79     repeat
  80
  81     2drop
  82 ;
  83
  84 :noname ( args -- string )
  85     2dup 1 ensure-arg-count
  86     car fixnum-type ensure-arg-type
  87
  88     2dup swap abs swap
  89
  90     fixnum-to-charlist ( fixnum charlist )
  91     2swap drop 0< if
  92         [char] - character-type 2swap cons
  93     then
  94
  95     drop string-type
  96 ; make-primitive number->string
  97
  98 :noname ( args -- symbol )
  99     2dup 1 ensure-arg-count
 100     car string-type ensure-arg-type
 101
 102     drop pair-type
 103
 104     2dup car [char] - character-type objeq? if
 105         cdr
 106         true -rot
 107     else
 108         2dup car [char] + character-type objeq? if
 109             cdr
 110         then
 111         false -rot
 112     then
 113
 114     0 -rot
 115     begin
 116         2dup nil objeq? false =
 117     while
 118         2dup car drop [char] 0 - -rot
 119         2swap swap 10 * + -rot
 120         cdr
 121     repeat
 122
 123     2drop
 124
 125     swap if -1 * then
 126
 127     fixnum-type
 128 ; make-primitive string->number
 129
 130 :noname ( args -- string )
 131     2dup 1 ensure-arg-count
 132     car symbol-type ensure-arg-type
 133
 134     drop pair-type
 135     duplicate-charlist
 136     drop string-type
 137 ; make-primitive symbol->string
 138
 139 :noname ( args -- symbol )
 140     2dup 1 ensure-arg-count
 141     car string-type ensure-arg-type
 142
 143     drop pair-type
 144     duplicate-charlist
 145     charlist>symbol
 146 ; make-primitive string->symbol
 147
 148 \ }}}
 149
 150 \ ==== Primitivle Arithmetic ==== {{{
 151
 152 \ --- Fixnums ---
 153
 154 :noname ( fixnum fixnum -- boolobj )
 155     objeq? boolean-type
 156 ; 2 make-fa-primitive fix:=
 157
 158 :noname ( fixnum fixnum -- boolobj )
 159     drop swap drop < 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 0= boolean-type
 176 ; 1 make-fa-primitive fix:zero?
 177
 178 :noname ( fixnum fixnum -- boolobj )
 179     drop 0> boolean-type
 180 ; 1 make-fa-primitive fix:positive?
 181
 182 :noname ( fixnum fixnum -- boolobj )
 183     drop 0< boolean-type
 184 ; 1 make-fa-primitive fix:negative?
 185
 186 :noname ( fixnum fixnum -- fixnum' )
 187     drop swap drop + fixnum-type
 188 ; 2 make-fa-primitive fix:+
 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:quotient
 201
 202 :noname ( fixnum fixnum -- fixnum' )
 203     drop swap drop mod fixnum-type
 204 ; 2 make-fa-primitive fix:remainder
 205
 206 :noname ( fixnum -- fixnum+1 )
 207     swap 1+ swap
 208 ; 1 make-fa-primitive fix:1+
 209
 210 :noname ( fixnum -- fixnum-1 )
 211     swap 1- swap
 212 ; 1 make-fa-primitive fix:-1+
 213
 214 :noname ( fixnum -- -fixnum )
 215     swap negate swap
 216 ; 1 make-fa-primitive fix:neg
 217
 218 ( Find the GCD of n1 and n2 where n2 < n1. )
 219 : gcd ( n1 n2 -- m )
 220
 221 ;
 222
 223 \ }}}
 224
 225 \ ==== Pairs and Lists ==== {{{
 226
 227 :noname ( arg1 arg2 -- pair )
 228     cons
 229 ; 2 make-fa-primitive cons
 230
 231 :noname ( pair-obj -- obj )
 232     car
 233 ; pair-type 1 make-fa-type-primitive car
 234
 235 :noname ( args -- obj )
 236     cdr
 237 ; pair-type 1 make-fa-type-primitive cdr
 238
 239 :noname ( pair obj  -- ok )
 240     2swap pair-type ensure-arg-type
 241
 242     set-car!
 243
 244     ok-symbol
 245 ; 2 make-fa-primitive set-car!
 246
 247 :noname ( pair obj -- ok )
 248     2swap pair-type ensure-arg-type
 249
 250     set-cdr!
 251
 252     ok-symbol
 253 ; 2 make-fa-primitive set-cdr!
 254
 255 \ }}}
 256
 257 \ ==== Polymorphic equality testing ==== {{{
 258
 259 :noname ( arg1 arg2 -- bool )
 260     objeq? boolean-type
 261 ; 2 make-fa-primitive eq?
 262
 263 \ }}}
 264
 265 \ ==== Input/Output ==== {{{
 266
 267 :noname ( args -- finalResult )
 268     drop pair-type
 269     pad charlist>cstr
 270     pad swap load
 271 ; string-type 1 make-fa-type-primitive load
 272
 273 :noname ( args -- obj )
 274     read
 275 ; 0 make-fa-primitive read
 276
 277 defer display
 278
 279 :noname ( obj -- none )
 280     print none
 281 ; 1 make-fa-primitive write
 282
 283 : displaypair ( pairobj -- )
 284     2dup
 285     car display
 286     cdr
 287     nil? if 2drop exit then
 288     pair-type istype? if space recurse exit then
 289     ."  . " display
 290 ;
 291
 292 : displaychar ( charobj -- )
 293     drop emit ;
 294
 295 : (displaystring) ( charlist -- )
 296     nil? if
 297         2drop
 298     else
 299         2dup car displaychar
 300         cdr recurse
 301     then
 302 ;
 303
 304 : displaystring ( stringobj -- )
 305     drop pair-type (displaystring)
 306 ;
 307
 308 :noname ( obj -- )
 309     pair-type istype? if ." (" displaypair ." )" exit then
 310     character-type istype? if displaychar exit then
 311     string-type istype? if displaystring exit then
 312
 313     print
 314 ; is display
 315
 316 :noname ( stringobj -- none )
 317     displaystring none
 318 ; string-type 1 make-fa-type-primitive display-string
 319
 320 :noname ( charobj -- none )
 321     displaychar none
 322 ; character-type 1 make-fa-type-primitive display-character
 323
 324 :noname ( obj -- none )
 325     display none
 326 ; 1 make-fa-primitive display
 327
 328 :noname ( args -- none )
 329     cr none
 330 ; 0 make-fa-primitive newline
 331
 332 \ }}}
 333
 334 \ ==== Evaluation ==== {{{
 335
 336 :noname ( args -- result )
 337     2dup car 2swap cdr
 338
 339     nil? false = if car then ( proc argvals )
 340
 341     apply
 342 ; make-primitive apply
 343
 344 \ }}}
 345
 346 \ ==== Miscellaneous  ==== {{{
 347
 348 ( Produce a recoverable exception. )
 349 :noname ( args -- result )
 350     bold fg red
 351
 352     nil? if
 353         ." Error."
 354     else
 355         ." Error: " car display
 356     then
 357
 358     reset-term
 359
 360     recoverable-exception throw
 361 ; make-primitive error
 362
 363 ( Generate a temporary unique symbol. Used in the creation of hygienic macros. )
 364 :noname ( args -- result )
 365     [char] _  character-type nil cons
 366     drop symbol-type
 367 ; 0 make-fa-primitive gensym
 368
 369 ( Generate the NONE object indicating an unspecified return value. )
 370 :noname ( args -- result )
 371     none
 372 ; 0 make-fa-primitive none
 373
 374 \ }}}
 375
 376 \ vim:fdm=marker