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 ;; not
 126
 127 (define-macro (not x)
 128               `(if ,x #f #t))
 129
 130 ;; FUNCTIONAL PROGRAMMING
 131
 132 (define (fold-left proc init l)
 133   (if (null? l)
 134     init
 135     (fold-left proc (proc init (car l)) (cdr l))))
 136
 137 (define (reduce-left proc init l)
 138   (if (null? l)
 139     init
 140     (if (null? (cdr l))
 141       (car l)
 142       (fold-left proc (proc (car l) (car (cdr l))) (cdr (cdr l))))))
 143
 144
 145 ;; NUMBERS
 146
 147 ; Rational primitives
 148
 149 (define (numerator x)
 150   (if (ratnum? x)
 151     (rat:numerator x)
 152     x))
 153
 154 (define (denominator x)
 155   (if (ratnum? x)
 156     (rat:denominator x)
 157     (if (fixnum? x)
 158       1
 159       1.0)))
 160
 161 (define (rat:+ x y)
 162   (make-rational (fix:+ (fix:* (numerator x) (denominator y))
 163                         (fix:* (denominator x) (numerator y)))
 164                  (fix:* (denominator x) (denominator y))))
 165
 166 (define (rat:- x y)
 167   (make-rational (fix:- (fix:* (numerator x) (denominator y))
 168                         (fix:* (denominator x) (numerator y)))
 169                  (fix:* (denominator x) (denominator y))))
 170
 171 (define (rat:* x y)
 172   (make-rational (fix:* (numerator x) (numerator y))
 173                  (fix:* (denominator x) (denominator y))))
 174
 175 (define (rat:/ x y)
 176   (make-rational (fix:* (numerator x) (denominator y))
 177                  (fix:* (denominator x) (numerator y))))
 178
 179 (define (rat:1/ x)
 180   (make-rational (denominator x) (numerator x)))
 181
 182 ; Type dispatch and promotion
 183
 184 (define (type-dispatch ops x)
 185   (if (flonum? x)
 186     ((cdr ops) x)
 187     ((car ops) x)))
 188
 189 (define (promote-dispatch ops x y)
 190   (if (flonum? x)
 191     (if (flonum? y)
 192       ((cdr ops) x y)
 193       ((cdr ops) x (fixnum->flonum y)))
 194     (if (flonum? y)
 195       ((cdr ops) (fixnum->flonum x) y)
 196       ((car ops) x y))))
 197
 198 ; Unary ops
 199
 200 (define (neg x)
 201   (type-dispatch (cons fix:neg flo:neg) x))
 202
 203 (define (abs x)
 204   (type-dispatch (cons fix:abs flo:abs) x))
 205
 206 (define (flo:1+ x) (flo:+ x 1.0))
 207 (define (flo:1- x) (flo:- x 1.0))
 208
 209 (define (1+ n)
 210   (type-dispatch (cons fix:1+ flo:1+) n))
 211
 212 (define (1- n)
 213   (type-dispatch (cons fix:1- flo:1-) n))
 214
 215 (define (apply-to-flonum op x)
 216   (if (flonum? x) (op x) x))
 217
 218 (define (round x)
 219   (apply-to-flonum flo:round x))
 220 (define (floor x)
 221   (apply-to-flonum flo:floor x))
 222 (define (ceiling x)
 223   (apply-to-flonum flo:ceiling x))
 224 (define (truncate x)
 225   (apply-to-flonum flo:truncate x))
 226
 227 ; Binary operations
 228
 229 (define (fix:/ x y) ; Non-standard definition while we don't have rationals
 230   (if (fix:= 0 (fix:remainder x y))
 231     (fix:quotient x y)
 232     (flo:/ (fixnum->flonum x) (fixnum->flonum y))))
 233
 234 (define (pair+ x y) (promote-dispatch (cons fix:+ flo:+) x y))
 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
 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 (define (pair<= x y) (promote-dispatch (cons fix:<= flo:<=) x y))
 243 (define (pair= x y) (promote-dispatch (cons fix:= flo:=) x y))
 244
 245 (define (null? arg)
 246   (eq? arg '()))
 247
 248 (define (+ . args)
 249   (fold-left pair+ 0 args))
 250
 251 (define (- first . rest)
 252   (if (null? rest)
 253     (neg first)
 254     (pair- first (apply + rest))))
 255
 256 (define (* . args)
 257   (fold-left pair* 1 args))
 258
 259 (define (/ first . rest)
 260   (if (null? rest)
 261     (pair/ 1 first)
 262     (pair/ first (apply * rest))))
 263
 264 (define (quotient n1 n2)
 265   (fix:quotient n1 n2))
 266
 267 (define (remainder n1 n2)
 268   (fix:remainder n1 n2))
 269
 270 (define modulo remainder)
 271
 272 ; Relations
 273
 274 (define (test-relation rel l)
 275   (if (null? l)
 276     #t
 277     (if (null? (cdr l))
 278       #t
 279       (if (rel (car l) (car (cdr l)))
 280         (test-relation rel (cdr l))
 281         #f))))
 282
 283 (define (= . args)
 284   (test-relation pair= args))
 285
 286 (define (> . args)
 287   (test-relation pair> args))
 288
 289 (define (< . args)
 290   (test-relation pair< args))
 291
 292 (define (>= . args)
 293   (test-relation pair>= args))
 294
 295 (define (<= . args)
 296   (test-relation pair<= args))
 297
 298 ; Numeric tests
 299
 300 (define (zero? x) (pair= x 0.0))
 301 (define (positive x) (pair> x 0.0))
 302 (define (odd? n) (pair= (remainder n 2) 0))
 303 (define (odd? n) (not (pair= (remainder n 2) 0)))
 304
 305
 306 ; Current state of the numerical tower
 307 (define (complex? x) #f)
 308 (define (real? x) #t)
 309 (define (rational? x) #t)
 310 (define (integer? x) (= x (round x)))
 311 (define (exact? x) (fixnum? x))
 312 (define (inexact? x) (flonum? x))
 313 (define (number? x)
 314   (if (fixnum? x) #t
 315     (if (flonum? x) #t
 316       (if (ratnum? x) #t #f))))
 317
 318
 319 ;; LISTS
 320
 321 ; List creation
 322 (define (list . args) args)
 323
 324 ; Return number of items in list
 325 (define (length l)
 326   (define (iter a count)
 327     (if (null? a)
 328       count
 329       (iter (cdr a) (fix:+ count 1))))
 330   (iter l 0))
 331
 332 ; Join two lists together
 333 (define (join l1 l2)
 334   (if (null? l1)
 335     l2
 336     (cons (car l1) (join (cdr l1) l2))))
 337
 338 ; Append an arbitrary number of lists together
 339 (define (append . lists)
 340   (if (null? lists)
 341     ()
 342     (if (null? (cdr lists))
 343       (car lists)
 344       (join (car lists) (apply append (cdr lists))))))
 345
 346 ; Reverse the contents of a list
 347 (define (reverse l)
 348   (if (null? l)
 349     ()
 350     (append (reverse (cdr l)) (list (car l)))))
 351
 352
 353 ;; TESTING
 354
 355 ; Test for the while macro.
 356 (define (count)
 357   (define counter 10)
 358   (while (> counter 0)
 359          (display counter) (newline)
 360          (set! counter (- counter 1))))
 361
 362 ; Basic iterative summation.  Run this on large numbers to
 363 ; test garbage collection and tail-call optimization.
 364 (define (sum n)
 365
 366   (define (sum-iter total count maxcount)
 367     (if (fix:> count maxcount)
 368       total
 369       (sum-iter (fix:+ total count) (fix:+ count 1) maxcount)))
 370
 371   (sum-iter 0 1 n))
 372
 373 ; Recursive summation. Use this to compare with tail call
 374 ; optimized iterative algorithm.
 375 (define (sum-recurse n)
 376   (if (fix:= n 0)
 377     0
 378     (fix:+ n (sum-recurse (fix:- n 1)))))
 379
 380
 381
 382 ;; MISC
 383
 384 (define (license)
 385   (display
 386 "This program is free software; you can redistribute it and/or modify
 387 it under the terms of the GNU General Public License as published by
 388 the Free Software Foundation; either version 3 of the License, or
 389 (at your option) any later version.
 390
 391 This program is distributed in the hope that it will be useful,
 392 but WITHOUT ANY WARRANTY; without even the implied warranty of
 393 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 394 GNU General Public License for more details.
 395
 396 You should have received a copy of the GNU General Public License
 397 along with this program. If not, see http://www.gnu.org/licenses/.
 398 "))
 399
 400 (define (welcome)
 401   (display
 402 "Welcome to scheme.forth.jl!
 403
 404 Copyright (C) 2016 Tim Vaughan.
 405 This program comes with ABSOLUTELY NO WARRANTY; for details type '(license)'.
 406 Use Ctrl-D to exit.
 407 "))