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