src/scheme-library.scm

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