X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=src%2Fscheme-library.scm;h=e462a00c7fb5bb456c21baf717fceba606494148;hb=41b469d050586a05cd43fdd4c78755616af3f7b4;hp=faa92884dc1fe17b13e8623aaa8344aec01d87ba;hpb=f675338306652fc8accf3c5ba154b915d0d24cdc;p=scheme.forth.jl.git diff --git a/src/scheme-library.scm b/src/scheme-library.scm index faa9288..e462a00 100644 --- a/src/scheme-library.scm +++ b/src/scheme-library.scm @@ -2,242 +2,36 @@ ;; Standard Library Procedures and Macros ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; NUMBERS - -; Arithmetic - -(define (null? arg) - (eq? arg '())) - -(define (fold-left proc init l) - (if (null? l) - init - (fold-left proc (proc init (car l)) (cdr l)))) - -(define (reduce-left proc init l) - (if (null? l) - init - (if (null? (cdr l)) - (car l) - (fold-left proc (proc (car l) (car (cdr l))) (cdr (cdr l)))))) - -(define (+ . args) - (fold-left fix:+ 0 args)) - -(define (- first . rest) - (if (null? rest) - (fix:neg first) - (fix:- first (apply + rest)))) - -(define (* . args) - (fold-left fix:* 1 args)) - -(define (quotient n1 n2) - (fix:quotient n1 n2)) - -(define (remainder n1 n2) - (fix:remainder n1 n2)) - -(define modulo remainder) - -(define (1+ n) - (fix:1+ n)) - -(define (-1+ n) - (fix:-1+ n)) - -; Relations - -(define (test-relation rel l) - (if (null? l) - #t - (if (null? (cdr l)) - #t - (if (rel (car l) (car (cdr l))) - (test-relation rel (cdr l)) - #f)))) - -(define (= . args) - (test-relation fix:= args)) - -(define (> . args) - (test-relation fix:> args)) - -(define (< . args) - (test-relation fix:< args)) - -(define (>= . args) - (test-relation fix:>= args)) - -(define (<= . args) - (test-relation fix:<= args)) - - - -; Current state of the numerical tower -(define complex? #f) -(define real? #f) -(define rational? #t) -(define integer? #t) -(define exact? #t) -(define inexact? #t) - -; Logic - -(define (not x) (if x #f #t)) - -;; LISTS - -(define (list . args) args) - - -(define (caar l) (car (car l))) -(define (cadr l) (car (cdr l))) -(define (cdar l) (cdr (car l))) -(define (cddr l) (cdr (cdr l))) -(define (cadar l) (car (cdr (car l)))) - -; Return number of items in list -(define (length l) - (define (iter a count) - (if (null? a) - count - (iter (cdr a) (+ count 1)))) - (iter l 0)) - -; Join two lists together -(define (join l1 l2) - (if (null? l1) - l2 - (cons (car l1) (join (cdr l1) l2)))) - -; Append an arbitrary number of lists together -(define (append . lists) - (if (null? lists) - () - (if (null? (cdr lists)) - (car lists) - (join (car lists) (apply append (cdr lists)))))) - -; Reverse the contents of a list -(define (reverse l) - (if (null? l) - () - (append (reverse (cdr l)) (list (car l))))) - - -;; LIBRARY SPECIAL FORMS - -; let - -(define (let-vars args) - (if (null? args) - '() - (cons (caar args) (let-vars (cdr args))))) - -(define (let-inits args) - (if (null? args) - '() - (cons (cadar args) (let-inits (cdr args))))) - -(define-macro (let args . body) - `((lambda ,(let-vars args) - ,@body) ,@(let-inits args))) - -; while - -(define-macro (while condition . body) - (let ((loop (gensym))) - `(begin - (define (,loop) - (if ,condition - (begin ,@body (,loop)))) - (,loop)))) - -; cond - -(define (cond-predicate clause) (car clause)) -(define (cond-actions clause) (cdr clause)) -(define (cond-else-clause? clause) - (eq? (cond-predicate clause) 'else)) - -(define (expand-clauses clauses) - (if (null? clauses) - (none) - (let ((first (car clauses)) - (rest (cdr clauses))) - (if (cond-else-clause? first) - (if (null? rest) - `(begin ,@(cond-actions first)) - (error "else clause isn't last in cond expression.")) - `(if ,(cond-predicate first) - (begin ,@(cond-actions first)) - ,(expand-clauses rest)))))) - -(define-macro (cond . clauses) - (if (null? clauses) - (error "cond requires at least one clause.") - (expand-clauses clauses))) - -; and - -(define (expand-and-expressions expressions) - (let ((first (car expressions)) - (rest (cdr expressions))) - (if (null? rest) - first - `(if ,first - ,(expand-and-expressions rest) - #f)))) - -(define-macro (and . expressions) - (if (null? expressions) - #t - (expand-and-expressions expressions))) - -; or - -(define (expand-or-expressions expressions) - (if (null? expressions) - #f - (let ((first (car expressions)) - (rest (cdr expressions)) - (val (gensym))) - `(let ((,val ,first)) - (if ,val - ,val - ,(expand-or-expressions rest)))))) - -(define-macro (or . expressions) - (expand-or-expressions expressions)) - - -;; TESTING - -(define-macro (backwards . body) - (cons 'begin (reverse body))) - -; Test for the while macro. -(define (count) - (define counter 10) - (while (> counter 0) - (display counter) (newline) - (set! counter (- counter 1)))) - -; Basic iterative summation. Run this on large numbers to -; test garbage collection and tail-call optimization. -(define (sum n) - - (define (sum-iter total count maxcount) - (if (> count maxcount) - total - (sum-iter (+ total count) (+ count 1) maxcount))) - - (sum-iter 0 1 n)) - -; Recursive summation. Use this to compare with tail call -; optimized iterative algorithm. -(define (sum-recurse n) - (if (= n 0) - 0 - (+ n (sum-recurse (- n 1))))) +(load "scheme-library-1-essential.scm") +(load "scheme-library-2-derived-forms.scm") +;(load "scheme-library-3-functional.scm") +;(load "scheme-library-4-numbers.scm") +;(load "scheme-library-5-lists.scm") +;(load "scheme-library-6-testing.scm") + +;; MISC + +(define (license) + (display +"This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program. If not, see http://www.gnu.org/licenses/. +")) + +(define (welcome) + (display +"Welcome to scheme.forth.jl! + +Copyright (C) 2016 Tim Vaughan. +This program comes with ABSOLUTELY NO WARRANTY; for details type '(license)'. +Use Ctrl-D to exit. +"))