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 ; let*
 257
 258 (define-macro (let* args . body)
 259               (if (null? args)
 260                 `(let () ,@body)
 261                 `(let (,(car args))
 262                    (let* ,(cdr args) ,@body))))
 263
 264 ; while
 265
 266 (define-macro (while condition . body)
 267               (let ((loop (gensym)))
 268                 `(begin
 269                    (define (,loop)
 270                      (if ,condition
 271                        (begin ,@body (,loop))))
 272                    (,loop))))
 273
 274 ; cond
 275
 276 ((lambda ()
 277    (define (cond-predicate clause) (car clause))
 278    (define (cond-actions clause) (cdr clause))
 279    (define (cond-else-clause? clause)
 280      (eq? (cond-predicate clause) 'else))
 281
 282    (define (expand-clauses clauses)
 283      (if (null? clauses)
 284        (none)
 285        (let ((first (car clauses))
 286              (rest (cdr clauses)))
 287          (if (cond-else-clause? first)
 288            (if (null? rest)
 289              `(begin ,@(cond-actions first))
 290              (error "else clause isn't last in cond expression."))
 291            `(if ,(cond-predicate first)
 292               (begin ,@(cond-actions first))
 293               ,(expand-clauses rest))))))
 294
 295    (define-macro (cond . clauses)
 296                  (if (null? clauses)
 297                    (error "cond requires at least one clause.")
 298                    (expand-clauses clauses)))
 299    ))
 300
 301 ; and
 302
 303 ((lambda ()
 304    (define (expand-and-expressions expressions)
 305      (let ((first (car expressions))
 306            (rest (cdr expressions)))
 307        (if (null? rest)
 308          first
 309          `(if ,first
 310             ,(expand-and-expressions rest)
 311             #f))))
 312
 313    (define-macro (and . expressions)
 314                  (if (null? expressions)
 315                    #t
 316                    (expand-and-expressions expressions)))
 317    ))
 318
 319 ; or
 320
 321 ((lambda ()
 322    (define (expand-or-expressions expressions)
 323      (if (null? expressions)
 324        #f
 325        (let ((first (car expressions))
 326              (rest (cdr expressions))
 327              (val (gensym)))
 328          `(let ((,val ,first))
 329             (if ,val
 330               ,val
 331               ,(expand-or-expressions rest))))))
 332
 333    (define-macro (or . expressions)
 334                  (expand-or-expressions expressions))
 335    ))
 336
 337
 338 ;; TESTING
 339
 340 (define-macro (backwards . body)
 341               (cons 'begin (reverse body)))
 342
 343 ; Test for the while macro.
 344 (define (count)
 345   (define counter 10)
 346   (while (> counter 0)
 347          (display counter) (newline)
 348          (set! counter (- counter 1))))
 349
 350 ; Basic iterative summation.  Run this on large numbers to
 351 ; test garbage collection and tail-call optimization.
 352 (define (sum n)
 353
 354   (define (sum-iter total count maxcount)
 355     (if (fix:> count maxcount)
 356       total
 357       (sum-iter (fix:+ total count) (fix:+ count 1) maxcount)))
 358
 359   (sum-iter 0 1 n))
 360
 361 ; Recursive summation. Use this to compare with tail call
 362 ; optimized iterative algorithm.
 363 (define (sum-recurse n)
 364   (if (fix:= n 0)
 365     0
 366     (fix:+ n (sum-recurse (fix:- n 1)))))
 367
 368 ;; MISC
 369
 370 (define (license)
 371   (display
 372 "This program is free software; you can redistribute it and/or modify
 373 it under the terms of the GNU General Public License as published by
 374 the Free Software Foundation; either version 3 of the License, or
 375 (at your option) any later version.
 376
 377 This program is distributed in the hope that it will be useful,
 378 but WITHOUT ANY WARRANTY; without even the implied warranty of
 379 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 380 GNU General Public License for more details.
 381
 382 You should have received a copy of the GNU General Public License
 383 along with this program. If not, see http://www.gnu.org/licenses/.
 384 "))
 385
 386 (define (welcome)
 387   (display
 388 "Welcome to scheme.forth.jl!
 389
 390 Copyright (C) 2016 Tim Vaughan.
 391 This program comes with ABSOLUTELY NO WARRANTY; for details type '(license)'.
 392 Use Ctrl-D to exit.
 393 "))