src/scheme-library.scm

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