src/scheme-library.scm

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; Standard Library Procedures and Macros ;;
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4
   5 ;; MISC
   6
   7 (define (not x) (if x #f #t))
   8
   9 (define (list . args) args)
  10
  11 (define (caar l) (car (car l)))
  12 (define (cadr l) (car (cdr l)))
  13 (define (cdar l) (cdr (car l)))
  14 (define (cddr l) (cdr (cdr l)))
  15 (define (cadar l) (car (cdr (car l))))
  16 (define (caddr l) (car (cdr (cdr l))))
  17 (define (cadddr l) (car (cdr (cdr (cdr l)))))
  18
  19 ;; FUNCTIONAL PROGRAMMING
  20
  21 (define (fold-left proc init l)
  22   (if (null? l)
  23     init
  24     (fold-left proc (proc init (car l)) (cdr l))))
  25
  26 (define (reduce-left proc init l)
  27   (if (null? l)
  28     init
  29     (if (null? (cdr l))
  30       (car l)
  31       (fold-left proc (proc (car l) (car (cdr l))) (cdr (cdr l))))))
  32
  33 (define (map proc l)
  34   (if (null? l)
  35     '()
  36     (cons (proc (car l)) (map proc (cdr l)))))
  37
  38 ;; NUMBERS
  39
  40 ; Rational primitives
  41
  42 (define (numerator x)
  43   (if (ratnum? x)
  44     (rat:numerator x)
  45     x))
  46
  47 (define (denominator x)
  48   (if (ratnum? x)
  49     (rat:denominator x)
  50     (if (fixnum? x)
  51       1
  52       1.0)))
  53
  54 (define (rat:+ x y)
  55   (make-rational (fix:+ (fix:* (numerator x) (denominator y))
  56                         (fix:* (denominator x) (numerator y)))
  57                  (fix:* (denominator x) (denominator y))))
  58
  59 (define (rat:- x y)
  60   (make-rational (fix:- (fix:* (numerator x) (denominator y))
  61                         (fix:* (denominator x) (numerator y)))
  62                  (fix:* (denominator x) (denominator y))))
  63
  64 (define (rat:* x y)
  65   (make-rational (fix:* (numerator x) (numerator y))
  66                  (fix:* (denominator x) (denominator y))))
  67
  68 (define (rat:/ x y)
  69   (make-rational (fix:* (numerator x) (denominator y))
  70                  (fix:* (denominator x) (numerator y))))
  71
  72 (define (rat:1/ x)
  73   (make-rational (denominator x) (numerator x)))
  74
  75 ; Type dispatch and promotion
  76
  77 (define (type-dispatch ops x)
  78   (if (flonum? x)
  79     ((cdr ops) x)
  80     ((car ops) x)))
  81
  82 (define (promote-dispatch ops x y)
  83   (if (flonum? x)
  84     (if (flonum? y)
  85       ((cdr ops) x y)
  86       ((cdr ops) x (fixnum->flonum y)))
  87     (if (flonum? y)
  88       ((cdr ops) (fixnum->flonum x) y)
  89       ((car ops) x y))))
  90
  91 ; Unary ops
  92
  93 (define (neg x)
  94   (type-dispatch (cons fix:neg flo:neg) x))
  95
  96 (define (abs x)
  97   (type-dispatch (cons fix:abs flo:abs) x))
  98
  99 (define (flo:1+ x) (flo:+ x 1.0))
 100 (define (flo:1- x) (flo:- x 1.0))
 101
 102 (define (1+ n)
 103   (type-dispatch (cons fix:1+ flo:1+) n))
 104
 105 (define (1- n)
 106   (type-dispatch (cons fix:1- flo:1-) n))
 107
 108 (define (apply-to-flonum op x)
 109   (if (flonum? x) (op x) x))
 110
 111 (define (round x)
 112   (apply-to-flonum flo:round x))
 113 (define (floor x)
 114   (apply-to-flonum flo:floor x))
 115 (define (ceiling x)
 116   (apply-to-flonum flo:ceiling x))
 117 (define (truncate x)
 118   (apply-to-flonum flo:truncate x))
 119
 120 ; Binary operations
 121
 122 (define (fix:/ x y) ; Non-standard definition while we don't have rationals
 123   (if (fix:= 0 (fix:remainder x y))
 124     (fix:quotient x y)
 125     (flo:/ (fixnum->flonum x) (fixnum->flonum y))))
 126
 127 (define (pair+ x y) (promote-dispatch (cons fix:+ flo:+) x y))
 128 (define (pair- x y) (promote-dispatch (cons fix:- flo:-) x y))
 129 (define (pair* x y) (promote-dispatch (cons fix:* flo:*) x y))
 130 (define (pair/ x y) (promote-dispatch (cons fix:/ flo:/) x y))
 131
 132 (define (pair> x y) (promote-dispatch (cons fix:> flo:>) x y))
 133 (define (pair< x y) (promote-dispatch (cons fix:< flo:<) x y))
 134 (define (pair>= x y) (promote-dispatch (cons fix:>= flo:>=) x y))
 135 (define (pair<= x y) (promote-dispatch (cons fix:<= flo:<=) x y))
 136 (define (pair= x y) (promote-dispatch (cons fix:= flo:=) x y))
 137
 138 (define (null? arg)
 139   (eq? arg '()))
 140
 141 (define (+ . args)
 142   (fold-left pair+ 0 args))
 143
 144 (define (- first . rest)
 145   (if (null? rest)
 146     (neg first)
 147     (pair- first (apply + rest))))
 148
 149 (define (* . args)
 150   (fold-left pair* 1 args))
 151
 152 (define (/ first . rest)
 153   (if (null? rest)
 154     (pair/ 1 first)
 155     (pair/ first (apply * rest))))
 156
 157 (define (quotient n1 n2)
 158   (fix:quotient n1 n2))
 159
 160 (define (remainder n1 n2)
 161   (fix:remainder n1 n2))
 162
 163 (define modulo remainder)
 164
 165 ; Relations
 166
 167 (define (test-relation rel l)
 168   (if (null? l)
 169     #t
 170     (if (null? (cdr l))
 171       #t
 172       (if (rel (car l) (car (cdr l)))
 173         (test-relation rel (cdr l))
 174         #f))))
 175
 176 (define (= . args)
 177   (test-relation pair= args))
 178
 179 (define (> . args)
 180   (test-relation pair> args))
 181
 182 (define (< . args)
 183   (test-relation pair< args))
 184
 185 (define (>= . args)
 186   (test-relation pair>= args))
 187
 188 (define (<= . args)
 189   (test-relation pair<= args))
 190
 191 ; Numeric tests
 192
 193 (define (zero? x) (pair= x 0.0))
 194 (define (positive x) (pair> x 0.0))
 195 (define (odd? n) (pair= (remainder n 2) 0))
 196 (define (odd? n) (not (pair= (remainder n 2) 0)))
 197
 198
 199 ; Current state of the numerical tower
 200 (define (complex? x) #f)
 201 (define (real? x) #t)
 202 (define (rational? x) #t)
 203 (define (integer? x) (= x (round x)))
 204 (define (exact? x) (fixnum? x))
 205 (define (inexact? x) (flonum? x))
 206
 207 ;; LISTS
 208
 209 ; Return number of items in list
 210 (define (length l)
 211   (define (iter a count)
 212     (if (null? a)
 213       count
 214       (iter (cdr a) (fix:+ count 1))))
 215   (iter l 0))
 216
 217 ; Join two lists together
 218 (define (join l1 l2)
 219   (if (null? l1)
 220     l2
 221     (cons (car l1) (join (cdr l1) l2))))
 222
 223 ; Append an arbitrary number of lists together
 224 (define (append . lists)
 225   (if (null? lists)
 226     ()
 227     (if (null? (cdr lists))
 228       (car lists)
 229       (join (car lists) (apply append (cdr lists))))))
 230
 231 ; Reverse the contents of a list
 232 (define (reverse l)
 233   (if (null? l)
 234     ()
 235     (append (reverse (cdr l)) (list (car l)))))
 236
 237
 238 ;; LIBRARY SPECIAL FORMS
 239
 240 ; let
 241
 242 (define (let-vars args)
 243   (if (null? args)
 244     '()
 245     (cons (caar args) (let-vars (cdr args)))))
 246
 247 (define (let-inits args)
 248   (if (null? args)
 249     '()
 250   (cons (cadar args) (let-inits (cdr args)))))
 251
 252 (define-macro (let args . body)
 253               `((lambda ,(let-vars args)
 254                  ,@body) ,@(let-inits args)))
 255
 256 ; while
 257
 258 (define-macro (while condition . body)
 259               (let ((loop (gensym)))
 260                 `(begin
 261                    (define (,loop)
 262                      (if ,condition
 263                        (begin ,@body (,loop))))
 264                    (,loop))))
 265
 266 ; cond
 267
 268 (define (cond-predicate clause) (car clause))
 269 (define (cond-actions clause) (cdr clause))
 270 (define (cond-else-clause? clause)
 271   (eq? (cond-predicate clause) 'else))
 272
 273 (define (expand-clauses clauses)
 274   (if (null? clauses)
 275     (none)
 276     (let ((first (car clauses))
 277           (rest (cdr clauses)))
 278       (if (cond-else-clause? first)
 279         (if (null? rest)
 280           `(begin ,@(cond-actions first))
 281           (error "else clause isn't last in cond expression."))
 282         `(if ,(cond-predicate first)
 283            (begin ,@(cond-actions first))
 284            ,(expand-clauses rest))))))
 285
 286 (define-macro (cond . clauses)
 287               (if (null? clauses)
 288                 (error "cond requires at least one clause.")
 289                 (expand-clauses clauses)))
 290
 291 ; and
 292
 293 (define (expand-and-expressions expressions)
 294   (let ((first (car expressions))
 295         (rest (cdr expressions)))
 296     (if (null? rest)
 297       first
 298       `(if ,first
 299          ,(expand-and-expressions rest)
 300          #f))))
 301
 302 (define-macro (and . expressions)
 303               (if (null? expressions)
 304                 #t
 305                 (expand-and-expressions expressions)))
 306
 307 ; or
 308
 309 (define (expand-or-expressions expressions)
 310   (if (null? expressions)
 311     #f
 312     (let ((first (car expressions))
 313           (rest (cdr expressions))
 314           (val (gensym)))
 315       `(let ((,val ,first))
 316          (if ,val
 317             ,val
 318             ,(expand-or-expressions rest))))))
 319
 320 (define-macro (or . expressions)
 321               (expand-or-expressions expressions))
 322
 323
 324 ;; TESTING
 325
 326 (define-macro (backwards . body)
 327               (cons 'begin (reverse body)))
 328
 329 ; Test for the while macro.
 330 (define (count)
 331   (define counter 10)
 332   (while (> counter 0)
 333          (display counter) (newline)
 334          (set! counter (- counter 1))))
 335
 336 ; Basic iterative summation.  Run this on large numbers to
 337 ; test garbage collection and tail-call optimization.
 338 (define (sum n)
 339
 340   (define (sum-iter total count maxcount)
 341     (if (fix:> count maxcount)
 342       total
 343       (sum-iter (fix:+ total count) (fix:+ count 1) maxcount)))
 344
 345   (sum-iter 0 1 n))
 346
 347 ; Recursive summation. Use this to compare with tail call
 348 ; optimized iterative algorithm.
 349 (define (sum-recurse n)
 350   (if (fix:= n 0)
 351     0
 352     (fix:+ n (sum-recurse (fix:- n 1)))))
 353
 354 ;; MISC
 355
 356 (define (license)
 357   (display
 358 "This program is free software; you can redistribute it and/or modify
 359 it under the terms of the GNU General Public License as published by
 360 the Free Software Foundation; either version 3 of the License, or
 361 (at your option) any later version.
 362
 363 This program is distributed in the hope that it will be useful,
 364 but WITHOUT ANY WARRANTY; without even the implied warranty of
 365 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 366 GNU General Public License for more details.
 367
 368 You should have received a copy of the GNU General Public License
 369 along with this program. If not, see http://www.gnu.org/licenses/.
 370 "))
 371
 372 (define (welcome)
 373   (display
 374 "Welcome to scheme.forth.jl!
 375
 376 Copyright (C) 2016 Tim Vaughan.
 377 This program comes with ABSOLUTELY NO WARRANTY; for details type '(license)'.
 378 Use Ctrl-D to exit.
 379 "))