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