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   (display "Expanding cond clauses...")
 275   (if (null? clauses)
 276     (none)
 277     (let ((first (car clauses))
 278           (rest (cdr clauses)))
 279       (if (cond-else-clause? first)
 280         (if (null? rest)
 281           `(begin ,@(cond-actions first))
 282           (error "else clause isn't last in cond expression."))
 283         `(if ,(cond-predicate first)
 284            (begin ,@(cond-actions first))
 285            ,(expand-clauses rest))))))
 286
 287 (define-macro (cond . clauses)
 288               (if (null? clauses)
 289                 (error "cond requires at least one clause.")
 290                 (expand-clauses clauses)))
 291
 292 ; and
 293
 294 (define (expand-and-expressions expressions)
 295   (let ((first (car expressions))
 296         (rest (cdr expressions)))
 297     (if (null? rest)
 298       first
 299       `(if ,first
 300          ,(expand-and-expressions rest)
 301          #f))))
 302
 303 (define-macro (and . expressions)
 304               (if (null? expressions)
 305                 #t
 306                 (expand-and-expressions expressions)))
 307
 308 ; or
 309
 310 (define (expand-or-expressions expressions)
 311   (if (null? expressions)
 312     #f
 313     (let ((first (car expressions))
 314           (rest (cdr expressions))
 315           (val (gensym)))
 316       `(let ((,val ,first))
 317          (if ,val
 318             ,val
 319             ,(expand-or-expressions rest))))))
 320
 321 (define-macro (or . expressions)
 322               (expand-or-expressions expressions))
 323
 324
 325 ;; TESTING
 326
 327 (define-macro (backwards . body)
 328               (cons 'begin (reverse body)))
 329
 330 ; Test for the while macro.
 331 (define (count)
 332   (define counter 10)
 333   (while (> counter 0)
 334          (display counter) (newline)
 335          (set! counter (- counter 1))))
 336
 337 ; Basic iterative summation.  Run this on large numbers to
 338 ; test garbage collection and tail-call optimization.
 339 (define (sum n)
 340
 341   (define (sum-iter total count maxcount)
 342     (if (fix:> count maxcount)
 343       total
 344       (sum-iter (fix:+ total count) (fix:+ count 1) maxcount)))
 345
 346   (sum-iter 0 1 n))
 347
 348 ; Recursive summation. Use this to compare with tail call
 349 ; optimized iterative algorithm.
 350 (define (sum-recurse n)
 351   (if (fix:= n 0)
 352     0
 353     (fix:+ n (sum-recurse (fix:- n 1)))))
 354
 355 ;; MISC
 356
 357 (define (license)
 358   (display
 359 "This program is free software; you can redistribute it and/or modify
 360 it under the terms of the GNU General Public License as published by
 361 the Free Software Foundation; either version 3 of the License, or
 362 (at your option) any later version.
 363
 364 This program is distributed in the hope that it will be useful,
 365 but WITHOUT ANY WARRANTY; without even the implied warranty of
 366 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 367 GNU General Public License for more details.
 368
 369 You should have received a copy of the GNU General Public License
 370 along with this program. If not, see http://www.gnu.org/licenses/.
 371 "))
 372
 373 (define (welcome)
 374   (display
 375 "Welcome to scheme.forth.jl!
 376
 377 Copyright (C) 2016 Tim Vaughan.
 378 This program comes with ABSOLUTELY NO WARRANTY; for details type '(license)'.
 379 Use Ctrl-D to exit.
 380 "))