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