src/scheme-library.scm

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