v08i056: Elk (Extension Language Toolkit) part 08 of 14
Brandon S. Allbery - comp.sources.misc
allbery at uunet.UU.NET
Sun Sep 24 07:41:23 AEST 1989
Posting-number: Volume 8, Issue 56
Submitted-by: net at tub.UUCP (Oliver Laumann)
Archive-name: elk/part08
[Let this be a lesson to submitters: this was submitted as uuencoded,
compressed files. I lost the source information while unpacking it; this
is the best approximation I could come up with. ++bsa]
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of archive 8 (of 14)."
# Contents: scm/xlib.core scm/oops tst/cc tst/dynamic-wind tst/fact
# tst/fact2 tst/fib tst/compile tst/hanoi tst/port tst/prim tst/rat+
# tst/runge-kutta tst/sqrt tst/unify tst/mondo tst/fix tst/ramanujan
# tst/Y tst/cell tst/co lib lib/xlib lib/xlib/examples
# lib/xlib/examples/lines lib/xlib/examples/hello
# lib/xlib/examples/poly
# Wrapped by net at tub on Sun Sep 17 17:32:30 1989
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f scm/xlib.core -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"scm/xlib.core\"
else
echo shar: Extracting \"scm/xlib.core\" \(8136 characters\)
sed "s/^X//" >scm/xlib.core <<'END_OF_scm/xlib.core'
X;;; -*-Scheme-*-
X;;;
X;;; X11 interface
X
X(require 'xlib.o)
X
X;;; High level create window function with keyword arguments
X
X(define-macro (make-window . attr)
X (let ((swa (make-vector (1+ (length set-window-attributes-slots)) ()))
X (parent #f) (x 0) (y 0) (width #f) (height #f) (border 2))
X (vector-set! swa 0 'set-window-attributes)
X (do ((a attr (cdr a))) ((null? a))
X (cond
X ((not (and (pair? (car a)) (= (length (car a)) 2)))
X (error 'make-window "bad argument ~s" (car a)))
X ((memq (caar a) '(parent x y width height border))
X (eval `(set! ,(caar a) (cadar a))))
X (else
X (let ((k (assq (caar a) set-window-attributes-slots)))
X (if k
X (eval `(vector-set! swa ,(cdr k) ,(cadar a)))
X (error 'make-window "unknown attribute: ~s" (car a)))))))
X (if (not (and width height))
X (error 'make-window "you must specify both width and height"))
X (if (not parent)
X (error 'make-window "you must specify a parent window"))
X `(create-window ,parent ,x ,y ,width ,height ,border ,swa)))
X
X
X;;; High level create gcontext with keyword arguments
X
X(define-macro (make-gcontext . attr)
X (let ((gcv (make-vector (1+ (length gcontext-slots)) ()))
X (win #f))
X (vector-set! gcv 0 'gcontext)
X (do ((a attr (cdr a))) ((null? a))
X (cond
X ((not (and (pair? (car a)) (= (length (car a)) 2)))
X (error 'make-gcontext "bad argument ~s" (car a)))
X ((eq? (caar a) 'window)
X (set! win (cadar a)))
X (else
X (let ((k (assq (caar a) gcontext-slots)))
X (if k
X (eval `(vector-set! gcv ,(cdr k) ,(cadar a)))
X (error 'make-gcontext "unknown attribute: ~s" (car a)))))))
X (if (not win)
X (error 'make-gcontext "you must specify a window"))
X `(create-gcontext ,win ,gcv)))
X
X
X;;; Definition of the access and update functions for window attributes,
X;;; geometry, gcontexts, etc.
X
X(define-macro (define-functions definer type fun pref)
X (let ((slots (string->symbol (format #f "~s-slots" type))))
X `(for-each eval (map (lambda (s)
X (,definer ',type (1+ (length ,slots)) ,fun s ,pref)) ,slots))))
X
X(define (define-accessor-with-cache type num-slots fun slot pref)
X (let ((name (string->symbol (format #f pref (car slot)))))
X `(define (,name object)
X (general-accessor object ',type ,fun ,(cdr slot)))))
X
X(define (define-mutator-with-cache type num-slots fun slot pref)
X (let ((name (string->symbol (format #f pref (car slot)))))
X `(define (,name object val)
X (general-mutator object val ',type ,num-slots ,fun ,(cdr slot)))))
X
X(define (define-accessor type num-slots fun slot pref)
X (let ((name (string->symbol (format #f pref (car slot)))))
X `(define (,name . args)
X (vector-ref (apply ,fun args) ,(cdr slot)))))
X
X
X(define-functions define-accessor-with-cache
X get-window-attributes get-window-attributes "window-~s")
X
X(define-functions define-mutator-with-cache
X set-window-attributes change-window-attributes "set-window-~s!")
X
X(define-functions define-mutator-with-cache
X window-configuration configure-window "set-window-~s!")
X
X(define-functions define-accessor-with-cache
X geometry get-geometry "drawable-~s")
X
X(define-functions define-mutator-with-cache
X gcontext change-gcontext "set-gcontext-~s!")
X
X(define-functions define-accessor-with-cache
X font-info font-info "font-~s")
X
X(define-functions define-accessor
X char-info char-info "char-~s")
X
X(define (min-char-info c) (char-info c 'min))
X(define (max-char-info c) (char-info c 'max))
X
X(define-functions define-accessor
X char-info min-char-info "min-char-~s")
X
X(define-functions define-accessor
X char-info max-char-info "max-char-~s")
X
X(define-functions define-accessor
X char-info text-extents "extents-~s")
X
X
X;;; ``cache'' is an a-list of (drawable-or-gcontext-or-font . state) pairs,
X;;; where state is a vector of buffers as listed below. Each slot in
X;;; a vector can be #f to indicate that the cache is empty. The cache
X;;; is manipulated by the ``with'' macro.
X
X(define cache ())
X
X(put 'set-window-attributes 'cache-slot 0)
X(put 'get-window-attributes 'cache-slot 1)
X(put 'window-configuration 'cache-slot 2)
X(put 'geometry 'cache-slot 3)
X(put 'gcontext 'cache-slot 4)
X(put 'font-info 'cache-slot 5)
X
X
X;;; List of buffers that are manipulated by mutator functions and must
X;;; be flushed using the associated update function when a ``with'' is
X;;; left (e.g., a set-window-attributes buffer is manipulated by
X;;; set-window-FOO functions; the buffer is flushed by a call to
X;;; (change-window-attributes WINDOW BUFFER)):
X
X(define mutable-types '(set-window-attributes window-configuration gcontext))
X
X(put 'set-window-attributes 'update-function change-window-attributes)
X(put 'window-configuration 'update-function configure-window)
X(put 'gcontext 'update-function change-gcontext)
X
X
X;;; Some types of buffers in the cache are invalidated when other
X;;; buffers are written to. For instance, a get-window-attributes
X;;; buffer for a window must be filled again when the window's
X;;; set-window-attributes or window-configuration buffers have been
X;;; written to.
X
X(put 'get-window-attributes 'invalidated-by
X '(set-window-attributes window-configuration))
X(put 'geometry 'invalidated-by
X '(set-window-attributes window-configuration))
X
X;;; Within the scope of a ``with'', the first call to a OBJECT-FOO
X;;; function causes the result of the corresponding Xlib function to
X;;; be retained in the cache; subsequent calls just read from the cache.
X;;; Similarly, calls to Xlib functions for set-OBJECT-FOO! functions are
X;;; delayed until exit of the ``with'' body or until a OBJECT-FOO
X;;; is called and the cached data for this accessor function has been
X;;; invalidated by the call to the mutator function (see ``invalidated-by''
X;;; property above).
X
X(define-macro (with object . body)
X `(if (assq ,object cache) ; if it's already in the cache, just
X (begin , at body) ; execute the body.
X (dynamic-wind
X (lambda ()
X (set! cache (cons (cons ,object (make-vector 6 #f)) cache)))
X (lambda ()
X , at body)
X (lambda ()
X (for-each (lambda (x) (flush-cache (car cache) x)) mutable-types)
X (set! cache (cdr cache))))))
X
X;;; If a mutator function has been called on an entry in the cache
X;;; of the given type, flush it by calling the right update function.
X
X(define (flush-cache entry type)
X (let* ((slot (get type 'cache-slot))
X (buf (vector-ref (cdr entry) slot)))
X (if buf
X (begin
X ((get type 'update-function) (car entry) buf)
X (vector-set! (cdr entry) slot #f)))))
X
X;;; General accessor function (OBJECT-FOO). See if the data in the
X;;; cache have been invalidated. If this is the case, or if the cache
X;;; has not yet been filled, fill it.
X
X(define (general-accessor object type fun slot)
X (let ((v) (entry (assq object cache)))
X (if entry
X (let ((cache-slot (get type 'cache-slot))
X (inval (get type 'invalidated-by)))
X (if inval
X (let ((must-flush #f))
X (for-each
X (lambda (x)
X (if (vector-ref (cdr entry) (get x 'cache-slot))
X (set! must-flush #t)))
X inval)
X (if must-flush
X (begin
X (for-each (lambda (x) (flush-cache entry x)) inval)
X (vector-set! (cdr entry) cache-slot #f)))))
X (if (not (vector-ref (cdr entry) cache-slot))
X (vector-set! (cdr entry) cache-slot (fun object)))
X (set! v (vector-ref (cdr entry) cache-slot)))
X (set! v (fun object)))
X (vector-ref v slot)))
X
X
X;;; General mutator function (set-OBJECT-FOO!). If the cache is empty,
X;;; put a new buffer of the given type and size into it. Write VAL
X;;; into the buffer.
X
X(define (general-mutator object val type num-slots fun slot)
X (let ((entry (assq object cache)))
X (if entry
X (let ((cache-slot (get type 'cache-slot)))
X (if (not (vector-ref (cdr entry) cache-slot))
X (let ((v (make-vector num-slots ())))
X (vector-set! v 0 type)
X (vector-set! (cdr entry) cache-slot v)
X (vector-set! v slot val))
X (vector-set! (vector-ref (cdr entry) cache-slot) slot val)))
X (let ((v (make-vector num-slots ())))
X (vector-set! v 0 type)
X (vector-set! v slot val)
X (fun object v)))))
END_OF_scm/xlib.core
if test 8136 -ne `wc -c <scm/xlib.core`; then
echo shar: \"scm/xlib.core\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f scm/oops -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"scm/oops\"
else
echo shar: Extracting \"scm/oops\" \(8713 characters\)
sed "s/^X//" >scm/oops <<'END_OF_scm/oops'
X;;; -*-Scheme-*-
X;;;
X;;; A simple oops package
X
X(require 'hack 'hack.o)
X
X(provide 'oops)
X
X(define class-size 5)
X(define instance-size 3)
X
X;;; Classes and instances are represented as vectors. The first
X;;; two slots (tag and class-name) are common to classes and instances.
X
X(define (tag v) (vector-ref v 0))
X(define (set-tag! v t) (vector-set! v 0 t))
X
X(define (class-name v) (vector-ref v 1))
X(define (set-class-name! v n) (vector-set! v 1 n))
X
X(define (class-instance-vars c) (vector-ref c 2))
X(define (set-class-instance-vars! c v) (vector-set! c 2 v))
X
X(define (class-env c) (vector-ref c 3))
X(define (set-class-env! c e) (vector-set! c 3 e))
X
X(define (class-super c) (vector-ref c 4))
X(define (set-class-super! c s) (vector-set! c 4 s))
X
X(define (instance-env i) (vector-ref i 2))
X(define (set-instance-env! i e) (vector-set! i 2 e))
X
X;;; Methods are bound in the class environment.
X
X(define (method-known? method class)
X (eval `(bound? ',method) (class-env class)))
X
X(define (lookup-method method class)
X (eval method (class-env class)))
X
X(define (class? c)
X (and (vector? c) (= (vector-length c) class-size) (eq? (tag c) 'class)))
X
X(define (check-class sym c)
X (if (not (class? c))
X (error sym "argument is not a class")))
X
X(define (instance? i)
X (and (vector? i) (= (vector-length i) instance-size)
X (eq? (tag i) 'instance)))
X
X(define (check-instance sym i)
X (if (not (instance? i))
X (error sym "argument is not an instance")))
X
X;;; Evaluate `body' within the scope of instance `i'.
X
X(define-macro (with-instance i . body)
X `(eval '(begin , at body) (instance-env ,i)))
X
X;;; Set a variable in an instance.
X
X(define (instance-set! instance var val)
X (eval `(set! ,var ',val) (instance-env instance)))
X
X;;; Set a class variable when no instance is available.
X
X(define (class-set! class var val)
X (eval `(set! ,var ',val) (class-env class)))
X
X;;; Convert a class variable spec into a binding suitable for a `let'.
X
X(define (make-binding var)
X (if (symbol? var)
X (list var ()) ; No initializer given; use ()
X var)) ; Initializer has been specified; leave alone
X
X;;; Check whether the elements of `vars' are either a symbol or
X;;; of the form (symbol initializer).
X
X(define (check-vars vars)
X (if (not (null? vars))
X (if (not (or (symbol? (car vars))
X (and (pair? (car vars)) (= (length (car vars)) 2)
X (symbol? (caar vars)))))
X (error 'define-class "bad variable spec: ~s" (car vars))
X (check-vars (cdr vars)))))
X
X;;; Check whether the class var spec `v' is already a member of
X;;; the list `l'. If this is the case, check whether the initializers
X;;; are identical.
X
X(define (find-matching-var l v)
X (cond
X ((null? l) #f)
X ((eq? (caar l) (car v))
X (if (not (equal? (cdar l) (cdr v)))
X (error 'define-class "initializer mismatch: ~s and ~s"
X (car l) v)
X #t))
X (else (find-matching-var (cdr l) v))))
X
X;;; Same as above, but don't check initializer.
X
X(define (find-var l v)
X (cond
X ((null? l) #f)
X ((eq? (caar l) (car v)) #t)
X (else (find-var (cdr l) v))))
X
X;;; Create a new list of class var specs by discarding all variables
X;;; from `b' that are already a member of `a' (with identical initializers).
X
X(define (join-vars a b)
X (cond
X ((null? b) a)
X ((find-matching-var a (car b)) (join-vars a (cdr b)))
X (else (join-vars (cons (car b) a) (cdr b)))))
X
X;;; The syntax is as follows:
X;;; (define-class class-name . options)
X;;; options are: (super-class class-name)
X;;; (class-vars . var-specs)
X;;; (instance-vars . var-specs)
X;;; each var-spec is either a symbol or (symbol initializer).
X
X(define-macro (define-class name . args)
X (let ((class-vars) (instance-vars (list (make-binding 'self)))
X (super) (super-class-env))
X (do ((a args (cdr a))) ((null? a))
X (cond
X ((not (pair? (car a)))
X (error 'define-class "bad argument: ~s" (car a)))
X ((eq? (caar a) 'class-vars)
X (check-vars (cdar a))
X (set! class-vars (cdar a)))
X ((eq? (caar a) 'instance-vars)
X (check-vars (cdar a))
X (set! instance-vars (append instance-vars
X (map make-binding (cdar a)))))
X ((eq? (caar a) 'super-class)
X (if (> (length (cdar a)) 1)
X (error 'define-class "only one super-class allowed"))
X (set! super (cadar a)))
X (else
X (error 'define-class "bad keyword: ~s" (caar a)))))
X (if super
X (let ((class (eval super)))
X (set! super-class-env (class-env class))
X (set! instance-vars (join-vars (class-instance-vars class)
X instance-vars)))
X (set! super-class-env (the-environment)))
X `(define ,name
X (let ((c (make-vector class-size ())))
X (set-tag! c 'class)
X (set-class-name! c ',name)
X (set-class-instance-vars! c ',instance-vars)
X (set-class-env! c (eval `(let* ,(map make-binding ',class-vars)
X (the-environment))
X ,super-class-env))
X (set-class-super! c ',super)
X c))))
X
X(define-macro (define-method class lambda-list . body)
X (if (not (pair? lambda-list))
X (error 'define-method "bad lambda list"))
X `(begin
X (check-class 'define-method ,class)
X (let ((env (class-env ,class))
X (method (car ',lambda-list))
X (args (cdr ',lambda-list))
X (forms ',body))
X (eval `(define ,method (lambda ,args , at forms)) env)
X #v)))
X
X;;; All arguments of the form (instance-var init-value) are used
X;;; to initialize the specified instance variable; then an
X;;; initialize-instance message is sent with all remaining
X;;; arguments.
X
X(define-macro (make-instance class . args)
X `(begin
X (check-class 'make-instance ,class)
X (let* ((e (the-environment))
X (i (make-vector instance-size #f))
X (class-env (class-env ,class))
X (instance-vars (class-instance-vars ,class)))
X (set-tag! i 'instance)
X (set-class-name! i ',class)
X (set-instance-env! i (eval `(let* ,instance-vars (the-environment))
X class-env))
X (eval `(set! self ,i) (instance-env i))
X (init-instance ',args ,class i e)
X i)))
X
X(define (init-instance args class instance env)
X (let ((other-args))
X (do ((a args (cdr a))) ((null? a))
X (if (and (pair? (car a)) (= (length (car a)) 2)
X (find-var (class-instance-vars class) (car a)))
X (instance-set! instance (caar a) (eval (cadar a) env))
X (set! other-args (cons (eval (car a) env) other-args))))
X (call-init-methods class instance (reverse! other-args))))
X
X;;; Call all initialize-instance methods in super-class to sub-class
X;;; order in the environment of `instance' with arguments `args'.
X
X(define (call-init-methods class instance args)
X (let ((called ()))
X (let loop ((class class))
X (if (class-super class)
X (loop (eval (class-super class))))
X (if (method-known? 'initialize-instance class)
X (let ((method (lookup-method 'initialize-instance class)))
X (if (not (memq method called))
X (begin
X (apply (hack-procedure-environment!
X method (instance-env instance))
X args)
X (set! called (cons method called)))))))))
X
X(define (send instance msg . args)
X (check-instance 'send instance)
X (let ((class (eval (class-name instance))))
X (if (not (method-known? msg class))
X (error 'send "message not understood: ~s" `(,msg , at args))
X (apply (hack-procedure-environment! (lookup-method msg class)
X (instance-env instance))
X args))))
X
X;;; If the message is not understood, return #f. Otherwise return
X;;; a list of one element, the result of the method.
X
X(define (send-if-handles instance msg . args)
X (check-instance 'send-if-handles instance)
X (let ((class (eval (class-name instance))))
X (if (not (method-known? msg class))
X #f
X (list (apply (hack-procedure-environment! (lookup-method msg class)
X (instance-env instance))
X args)))))
X
X(define (describe-class c)
X (check-class 'describe-class c)
X (format #t "Class name: ~s~%" (class-name c))
X (format #t "Superclass: ~s~%"
X (if (class-super c)
X (class-super c)
X 'None))
X (format #t "Instancevars: ")
X (do ((v (class-instance-vars c) (cdr v)) (space #f #t)) ((null? v))
X (if space
X (format #t " "))
X (print (cons (caar v) (cadar v))))
X (format #t "Classvars/Methods: ")
X (define v (car (environment->list (class-env c))))
X (if v
X (do ((f v (cdr f)) (space #f #t)) ((null? f))
X (if space
X (format #t " "))
X (print (car f)))
X (print 'None))
X #v)
X
X(define (describe-instance i)
X (check-instance 'describe-instance i)
X (format #t "Instance of: ~s~%" (class-name i))
X (format #t "Instancevars: ")
X (do ((f (car (environment->list (instance-env i))) (cdr f))
X (space #f #t)) ((null? f))
X (if space
X (format #t " "))
X (print (car f)))
X #v)
END_OF_scm/oops
if test 8713 -ne `wc -c <scm/oops`; then
echo shar: \"scm/oops\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/cc -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/cc\"
else
echo shar: Extracting \"tst/cc\" \(474 characters\)
sed "s/^X//" >tst/cc <<'END_OF_tst/cc'
X;;; -*-Scheme-*-
X
X(define acc)
X(define bcc)
X(define n 5)
X
X(define (a)
X (if (not (= 0 (call-with-current-continuation
X (lambda (cc)
X (set! acc cc) 0))))
X (if (> n 0)
X (begin
X (set! n (- n 1))
X (display "resume b") (newline)
X (bcc 1))
X #v)
X acc))
X
X(define (b)
X (if (not (= 0 (call-with-current-continuation
X (lambda (cc)
X (set! bcc cc) 0))))
X (begin
X (display "resume a") (newline)
X (acc 1)))
X bcc)
X
X(a)
X(b)
X(acc 1)
END_OF_tst/cc
if test 474 -ne `wc -c <tst/cc`; then
echo shar: \"tst/cc\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/dynamic-wind -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/dynamic-wind\"
else
echo shar: Extracting \"tst/dynamic-wind\" \(641 characters\)
sed "s/^X//" >tst/dynamic-wind <<'END_OF_tst/dynamic-wind'
X;;; -*-Scheme-*-
X
X(define point)
X(define saved #f)
X(define (print s) (display s) (newline))
X
X(define (inner)
X (dynamic-wind
X (lambda () (print " in"))
X (lambda () (dynamic-wind
X (lambda () (print " in"))
X (lambda () (if saved
X (begin (print " throw") (point 100))
X (begin
X (call-with-current-continuation
X (lambda (x) (set! point x)))
X (print " catch")
X (set! saved #t) #v)))
X (lambda () (print " out"))))
X (lambda () (print " out"))))
X
X(define (outer)
X (dynamic-wind
X (lambda () (print 'in))
X (lambda () (inner))
X (lambda () (print 'out))))
X
X(outer)
X(outer)
END_OF_tst/dynamic-wind
if test 641 -ne `wc -c <tst/dynamic-wind`; then
echo shar: \"tst/dynamic-wind\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/fact -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/fact\"
else
echo shar: Extracting \"tst/fact\" \(197 characters\)
sed "s/^X//" >tst/fact <<'END_OF_tst/fact'
X;;; -*-Scheme-*-
X
X(define (factorial n)
X (define (iter product counter)
X (if (> counter n)
X product
X (iter (* counter product)
X (+ counter 1))))
X (iter 1 1))
X
X(print (factorial 10))
END_OF_tst/fact
if test 197 -ne `wc -c <tst/fact`; then
echo shar: \"tst/fact\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/fact2 -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/fact2\"
else
echo shar: Extracting \"tst/fact2\" \(122 characters\)
sed "s/^X//" >tst/fact2 <<'END_OF_tst/fact2'
X;;; -*-Scheme-*-
X
X(define (f n)
X (let fact ((i n) (a 1))
X (if (zero? i)
X a
X (fact (- i 1) (* a i)))))
X
X(print (f 10))
END_OF_tst/fact2
if test 122 -ne `wc -c <tst/fact2`; then
echo shar: \"tst/fact2\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/fib -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/fib\"
else
echo shar: Extracting \"tst/fib\" \(290 characters\)
sed "s/^X//" >tst/fib <<'END_OF_tst/fib'
X;;; -*-Scheme-*-
X
X(define (f n)
X (if (= n 0)
X 0
X (let fib ((i n) (a1 1) (a2 0))
X (if (= i 1)
X a1
X (fib (- i 1) (+ a1 a2) a1)))))
X
X(print (f 20))
X
X(define tau (/ (+ 1 (sqrt 5.0)) 2))
X
X(define (fib n)
X (/ (+ (expt tau n) (expt tau (- 0 n))) (sqrt 5.0)))
X
X(print (fib 20))
END_OF_tst/fib
if test 290 -ne `wc -c <tst/fib`; then
echo shar: \"tst/fib\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/compile -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/compile\"
else
echo shar: Extracting \"tst/compile\" \(10445 characters\)
sed "s/^X//" >tst/compile <<'END_OF_tst/compile'
X(require 'cscheme)
X
X;
X; Optimizing scheme compiler
X; supports quote, set!, if, lambda special forms,
X; constant refs, variable refs and proc applications
X;
X; Using Clusures for Code Generation
X; Marc Feeley and Guy LaPalme
X; Computer Language, Vol. 12, No. 1, pp. 47-66
X; 1987
X;
X
X(define (compile expr)
X ((gen expr nil ())))
X
X(define (gen expr env term)
X (cond
X ((symbol? expr)
X (ref (variable expr env) term))
X ((not (pair? expr))
X (cst expr term))
X ((eq? (car expr) 'quote)
X (cst (cadr expr) term))
X ((eq? (car expr) 'set!)
X (set (variable (cadr expr) env) (gen (caddr expr) env ()) term))
X ((eq? (car expr) 'if)
X (gen-tst (gen (cadr expr) env ())
X (gen (caddr expr) env term)
X (gen (cadddr expr) env term)))
X ((eq? (car expr) 'lambda)
X (let ((p (cadr expr)))
X (prc p (gen (caddr expr) (allocate p env) #t) term)))
X (else
X (let ((args (map (lambda (x) (gen x env ())) (cdr expr))))
X (let ((var (and (symbol? (car expr)) (variable (car expr) env))))
X (if (global? var)
X (app (cons var args) #t term)
X (app (cons (gen (car expr) env ()) args) () term)))))))
X
X
X(define (allocate parms env)
X (cond ((null? parms) env)
X ((symbol? parms) (cons parms env))
X (else
X (cons (car parms) (allocate (cdr parms) env)))))
X
X(define (variable symb env)
X (let ((x (memq symb env)))
X (if x
X (- (length env) (length x))
X (begin
X (if (not (assq symb -glo-env-)) (define-global symb '-undefined-))
X (assq symb -glo-env-)))))
X
X(define (global? var)
X (pair? var))
X
X(define (cst val term)
X (cond ((eqv? val 1)
X ((if term gen-1* gen-1)))
X ((eqv? val 2)
X ((if term gen-2* gen-2)))
X ((eqv? val nil)
X ((if term gen-null* gen-null)))
X (else
X ((if term gen-cst* gen-cst) val))))
X
X(define (ref var term)
X (cond ((global? var)
X ((if term gen-ref-glo* gen-ref-glo) var))
X ((= var 0)
X ((if term gen-ref-loc-1* gen-ref-loc-1)))
X ((= var 1)
X ((if term gen-ref-loc-2* gen-ref-loc-2)))
X ((= var 2)
X ((if term gen-ref-loc-3* gen-ref-loc-3)))
X (else
X ((if term gen-ref* gen-ref) var))))
X
X(define (set var val term)
X (cond ((global? var)
X ((if term gen-set-glo* gen-set-glo) var val))
X ((= var 0)
X ((if term gen-set-loc-1* gen-set-loc-1) val))
X ((= var 1)
X ((if term gen-set-loc-2* gen-set-loc-2) val))
X ((= var 2)
X ((if term gen-set-loc-3* gen-set-loc-3) val))
X (else
X ((if term gen-set* gen-set) var val))))
X
X(define (prc parms body term)
X ((cond ((null? parms)
X (if term gen-pr0* gen-pr0))
X ((symbol? parms)
X (if term gen-pr1/rest* gen-pr1/rest))
X ((null? (cdr parms))
X (if term gen-pr1* gen-pr1))
X ((symbol? (cdr parms))
X (if term gen-pr2/rest* gen-pr2/rest))
X ((null? (cddr parms))
X (if term gen-pr2* gen-pr2))
X ((symbol? (cddr parms))
X (if term gen-pr3/rest* gen-pr3/rest))
X ((null? (cdddr parms))
X (if term gen-pr3 gen-pr3))
X (else
X (error "too many parameters in a lambda-expression")))
X body))
X
X(define (app vals glo term)
X (apply (case (length vals)
X ((1) (if glo
X (if term gen-ap0-glo* gen-ap0-glo)
X (if term gen-ap0* gen-ap0)))
X ((2) (if glo
X (if term gen-ap1-glo* gen-ap1-glo)
X (if term gen-ap1* gen-ap1)))
X ((3) (if glo
X (if term gen-ap2-glo* gen-ap2-glo)
X (if term gen-ap2* gen-ap2)))
X ((4) (if glo
X (if term gen-ap3-glo* gen-ap3-glo)
X (if term gen-ap3* gen-ap3)))
X (else (error "too many arguments in a proc application")))
X vals))
X;
X; code generation for non-terminal evaluations
X;
X
X;
X; constants
X;
X
X(define (gen-1) (lambda () 1))
X(define (gen-2) (lambda () 2))
X(define (gen-null) (lambda () ()))
X(define (gen-cst a) (lambda () a))
X
X;
X; variable reference
X;
X
X(define (gen-ref-glo a) (lambda () (cdr a))) ; global var
X(define (gen-ref-loc-1) (lambda () (cadr *env*))) ; first local var
X(define (gen-ref-loc-2) (lambda () (caddr *env*))) ; second local var
X(define (gen-ref-loc-3) (lambda () (cadddr *env*))) ; third local var
X(define (gen-ref a) (lambda () (do ((i 0 (1+ i)) ; any non-global
X (env (cdr *env*) (cdr env)))
X ((= i a) (car env)))))
X
X;
X; assignment
X;
X
X(define (gen-set-glo a b) (lambda () (set-cdr! a (b))))
X(define (gen-set-loc-1 a) (lambda () (set-car! (cdr *env*) (a))))
X(define (gen-set-loc-2 a) (lambda () (set-car! (cddr *env*) (a))))
X(define (gen-set-loc-3 a) (lambda () (set-car! (cdddr *env*) (a))))
X(define (gen-set a b) (lambda () (do ((i 0 (1+ i))
X (env (cdr *env*) (cdr env)))
X ((= i a) (set-car! env (b))))))
X
X;
X; conditional
X;
X
X(define (gen-tst a b c) (lambda () (if (a) (b) (c))))
X
X;
X; procedure application
X;
X
X(define (gen-ap0-glo a) (lambda () ((cdr a))))
X(define (gen-ap1-glo a b) (lambda () ((cdr a) (b))))
X(define (gen-ap2-glo a b c) (lambda () ((cdr a) (b) (c))))
X(define (gen-ap3-glo a b c d) (lambda () ((cdr a) (b) (c) (d))))
X
X(define (gen-ap0 a) (lambda () ((a))))
X(define (gen-ap1 a b) (lambda () ((a) (b))))
X(define (gen-ap2 a b c) (lambda () ((a) (b) (c))))
X(define (gen-ap3 a b c d) (lambda () ((a) (b) (c) (d))))
X
X;
X; lambda expressions
X;
X
X(define (gen-pr0 a) ; without "rest" parameter
X (lambda ()
X (let ((def (cdr *env*)))
X (lambda ()
X (set! *env* (cons *env* def))
X (a)))))
X
X(define (gen-pr1 a)
X (lambda ()
X (let ((def (cdr *env*)))
X (lambda (x)
X (set! *env* (cons *env* (cons x def)))
X (a)))))
X
X(define (gen-pr2 a)
X (lambda ()
X (let ((def (cdr *env*)))
X (lambda (x y)
X (set! *env* (cons *env* (cons x (cons y def))))
X (a)))))
X
X(define (gen-pr3 a)
X (lambda ()
X (let ((def (cdr *env*)))
X (lambda (x y z)
X (set! *env* (cons *env* (cons x (cons y (cons z def)))))
X (a)))))
X
X(define (gen-pr1/rest a)
X (lambda ()
X (let ((def (cdr *env*)))
X (lambda x
X (set! *env* (cons *env* (cons x def)))
X (a)))))
X
X(define (gen-pr2/rest a)
X (lambda ()
X (let ((def (cdr *env*)))
X (lambda (x . y)
X (set! *env* (cons *env* (cons x (cons y def))))
X (a)))))
X
X(define (gen-pr3/rest a)
X (lambda ()
X (let ((def (cdr *env*)))
X (lambda (x y . z)
X (set! *env* (cons *env* (cons x (cons y (cons z def)))))
X (a)))))
X
X;
X; code generation for terminal evaluations
X;
X
X;
X; constants
X;
X
X(define (gen-1*)
X (lambda ()
X (set! *env* (car *env*))
X 1))
X
X(define (gen-2*)
X (lambda ()
X (set! *env* (car *env*))
X 2))
X
X(define (gen-null*)
X (lambda ()
X (set! *env* (car *env*))
X ()))
X
X(define (gen-cst* a)
X (lambda ()
X (set! *env* (car *env*))
X a))
X
X;
X; variable reference
X;
X
X(define (gen-ref-glo* a)
X (lambda ()
X (set! *env* (car *env*))
X (cdr a)))
X
X(define (gen-ref-loc-1*)
X (lambda ()
X (let ((val (cadr *env*)))
X (set! *env* (car *env*))
X val)))
X
X(define (gen-ref-loc-2*)
X (lambda ()
X (let ((val (caddr *env*)))
X (set! *env* (car *env*))
X val)))
X
X(define (gen-ref-loc-3*)
X (lambda ()
X (let ((val (cadddr *env*)))
X (set! *env* (car *env*))
X val)))
X
X(define (gen-ref* a)
X (lambda ()
X (do ((i 0 (1+ i))
X (env (cdr *env*) (cdr env)))
X ((= i a)
X (set! *env* (car *env*))
X (car env)))))
X
X;
X; assignment
X;
X
X(define (gen-set-glo* a b)
X (lambda ()
X (set! *env* (car *env*))
X (set-cdr! a (b))))
X
X(define (gen-set-loc-1* a)
X (lambda ()
X (set! *env* (car *env*))
X (set-car! (cdr *env*) (a))))
X
X(define (gen-set-loc-2* a)
X (lambda ()
X (set! *env* (car *env*))
X (set-car! (cddr *env*) (a))))
X
X(define (gen-set-loc-3* a)
X (lambda ()
X (set! *env* (car *env*))
X (set-car! (cdddr *env*) (a))))
X
X(define (gen-set* a b)
X (lambda ()
X (do ((i 0 (1+ i))
X (env (cdr *env*) (cdr env)))
X ((= i 0)
X (set! *env* (car *env*))
X (set-car! env (b))))))
X
X;
X; procedure application
X;
X
X(define (gen-ap0-glo* a)
X (lambda ()
X (set! *env* (car *env*))
X ((cdr a))))
X
X(define (gen-ap1-glo* a b)
X (lambda ()
X (let ((x (b)))
X (set! *env* (car *env*))
X ((cdr a) x))))
X
X(define (gen-ap2-glo* a b c)
X (lambda ()
X (let ((x (b)) (y (c)))
X (set! *env* (car *env*))
X ((cdr a) x y))))
X
X(define (gen-ap3-glo* a b c d)
X (lambda ()
X (let ((x (b)) (y (c)) (z (d)))
X (set! *env* (car *env*))
X ((cdr a) x y z))))
X
X(define (gen-ap0* a)
X (lambda ()
X (let ((w (a)))
X (set! *env* (car *env*))
X (w))))
X
X(define (gen-ap1* a b)
X (lambda ()
X (let ((w (a)) (x (b)))
X (set! *env* (car *env*))
X (w x))))
X
X(define (gen-ap2* a b c)
X (lambda ()
X (let ((w (a)) (x (b)) (y (c)))
X (set! *env* (car *env*))
X (w x y))))
X
X(define (gen-ap3* a b c d)
X (lambda ()
X (let ((w (a)) (x (b)) (y (c)) (z (d)))
X (set! *env* (car *env*))
X (w x y z))))
X
X;
X; lambda
X;
X
X(define (gen-pr0* a)
X (lambda ()
X (let ((def (cdr *env*)))
X (set! *env* (car *env*))
X (lambda ()
X (set! *env* (cons *env* def))
X (a)))))
X
X
X(define (gen-pr1* a)
X (lambda ()
X (let ((def (cdr *env*)))
X (set! *env* (car *env*))
X (lambda (x)
X (set! *env* (cons *env* (cons x def)))
X (a)))))
X
X(define (gen-pr2* a)
X (lambda ()
X (let ((def (cdr *env*)))
X (set! *env* (car *env*))
X (lambda (x y)
X (set! *env* (cons *env* (cons x (cons y def))))
X (a)))))
X
X(define (gen-pr3* a)
X (lambda ()
X (let ((def (cdr *env*)))
X (set! *env* (car *env*))
X (lambda (x y z)
X (set! *env* (cons *env* (cons x (cons y (cons z def)))))
X (a)))))
X
X(define (gen-pr1/rest* a)
X (lambda ()
X (let ((def (cdr *env*)))
X (set! *env* (car *env*))
X (lambda x
X (set! *env* (cons *env* (cons x def)))
X (a)))))
X
X(define (gen-pr2/rest* a)
X (lambda ()
X (let ((def (cdr *env*)))
X (set! *env* (car *env*))
X (lambda (x . y)
X (set! *env* (cons *env* (cons x (cons y def))))
X (a)))))
X
X(define (gen-pr1/rest* a)
X (lambda ()
X (let ((def (cdr *env*)))
X (set! *env* (car *env*))
X (lambda (x y . z)
X (set! *env* (cons *env* (cons x (cons y (cons z def)))))
X (a)))))
X
X;
X; global defs
X;
X
X(define (define-global var val)
X (if (assq var -glo-env-)
X (set-cdr! (assq var -glo-env-) val)
X (set! -glo-env- (cons (cons var val) -glo-env-))))
X
X(define -glo-env- (list (cons 'define define-global)))
X
X(define-global 'cons cons)
X(define-global 'car car)
X(define-global 'cdr cdr)
X(define-global 'null? null?)
X(define-global 'not not)
X(define-global '< <)
X(define-global '-1+ -1+)
X(define-global '+ +)
X(define-global '- -)
X
X;
X; current environment
X;
X
X(define *env* '(dummy))
X
X;
X; environment manipulation
X;
X
X(define (restore-env)
X (set! *env* (car *env*)))
X
X;
X; evaluator
X;
X
X(define (evaluate expr)
X ((compile (list 'lambda '() expr))))
X
X
X (evaluate '(define 'fib
X (lambda (x)
X (if (< x 2)
X x
X (+ (fib (- x 1))
X (fib (- x 2)))))))
X
X(print (evaluate '(fib 10)))
END_OF_tst/compile
if test 10445 -ne `wc -c <tst/compile`; then
echo shar: \"tst/compile\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/hanoi -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/hanoi\"
else
echo shar: Extracting \"tst/hanoi\" \(399 characters\)
sed "s/^X//" >tst/hanoi <<'END_OF_tst/hanoi'
X;;; -*-Scheme-*-
X;;;
X;;; Towers of Hanoi
X
X(define (hanoi n)
X (if (zero? n)
X (display "Huh?\n")
X (transfer 'A 'B 'C n)))
X
X(define (print-move from to)
X (format #t "Move disk from ~s to ~s~%" from to))
X
X(define (transfer from to via n)
X (if (= n 1)
X (print-move from to)
X (transfer from via to (1- n))
X (print-move from to)
X (transfer via to from (1- n))))
X
X(hanoi 3)
END_OF_tst/hanoi
if test 399 -ne `wc -c <tst/hanoi`; then
echo shar: \"tst/hanoi\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/port -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/port\"
else
echo shar: Extracting \"tst/port\" \(480 characters\)
sed "s/^X//" >tst/port <<'END_OF_tst/port'
X;;; -*-Scheme-*-
X
X(let ((s1 (make-string 63 #\a))
X (s2 (make-string 66 #\b))
X (s3 (make-string 1500 #\c))
X (f (open-output-string)))
X (display s1 f)
X (display s2 f)
X (display s3 f)
X (display (string-append (get-output-string f) ".") f)
X (write (string-length (get-output-string f)))
X (display " ")
X (print (+ 1 63 66 1500))
X (define f (open-input-string s2))
X (write (string-length s2))
X (display " ")
X (print (string-length (symbol->string (read f)))))
END_OF_tst/port
if test 480 -ne `wc -c <tst/port`; then
echo shar: \"tst/port\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/prim -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/prim\"
else
echo shar: Extracting \"tst/prim\" \(229 characters\)
sed "s/^X//" >tst/prim <<'END_OF_tst/prim'
X;;; -*-Scheme-*-
X
X(define (p n)
X (let f ((n n) (i 2))
X (cond
X ((> i n) ())
X ((integer? (/ n i))
X (cons i (f (/ n i) i)))
X (else
X (f n (+ i 1))))))
X
X(print (p 12))
X(print (p 3628800))
X(print (p 4194304))
END_OF_tst/prim
if test 229 -ne `wc -c <tst/prim`; then
echo shar: \"tst/prim\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/rat+ -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/rat+\"
else
echo shar: Extracting \"tst/rat+\" \(668 characters\)
sed "s/^X//" >tst/rat+ <<'END_OF_tst/rat+'
X;;; -*-Scheme-*-
X
X(define (rat? r) (and (pair? r)
X (integer? (car r))
X (integer? (cdr r))
X (positive? (cdr r))))
X
X(define (rat+ . args)
X (if (memq #f (map rat? args))
X (display "Wrong argument type in rat+")
X (let* ((denominator (abs (apply lcm (map cdr args))))
X (numerator (apply + (map (lambda (quotient)
X (* (car quotient)
X (/ denominator (cdr quotient))))
X args)))
X (common-divisor (abs (gcd numerator denominator))))
X (cons (/ numerator common-divisor)
X (/ denominator common-divisor)))))
X
X(print (rat+ 1 2))
X(print (rat+ '(1 . 3) '(1 . 7)))
X(print (rat+ (rat+ '(1 . 2) '(1 . 4)) '(1 . 4)))
END_OF_tst/rat+
if test 668 -ne `wc -c <tst/rat+`; then
echo shar: \"tst/rat+\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/runge-kutta -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/runge-kutta\"
else
echo shar: Extracting \"tst/runge-kutta\" \(1755 characters\)
sed "s/^X//" >tst/runge-kutta <<'END_OF_tst/runge-kutta'
X;;; -*-Scheme-*-
X
X(define integrate-system
X (lambda (system-derivative initial-state h)
X (let ((next (runge-kutta-4 system-derivative h)))
X (letrec ((states
X (cons initial-state
X (delay (map-streams next
X states)))))
X states))))
X
X(define runge-kutta-4
X (lambda (f h)
X (let ((*h (scale-vector h))
X (*2 (scale-vector 2))
X (*1/2 (scale-vector (/ 1 2)))
X (*1/6 (scale-vector (/ 1 6))))
X (lambda (y)
X (let* ((k0 (*h (f y)))
X (k1 (*h (f (add-vectors y (*1/2 k0)))))
X (k2 (*h (f (add-vectors y (*1/2 k1)))))
X (k3 (*h (f (add-vectors y k2)))))
X (add-vectors y
X (*1/6 (add-vectors k0
X (*2 k1)
X (*2 k2)
X k3))))))))
X
X(define element-wise
X (lambda (f)
X (lambda vectors
X (generate-vector
X (vector-length (car vectors))
X (lambda (i)
X (apply f
X (map (lambda (v) (vector-ref v i))
X vectors)))))))
X
X(define generate-vector
X (lambda (size proc)
X (let ((ans (make-vector size)))
X (letrec ((loop
X (lambda (i)
X (cond ((= i size) ans)
X (else
X (vector-set! ans 1 (proc i))
X (loop (+ i 1)))))))
X (loop 0)))))
X
X(define add-vectors (element-wise +))
X
X(define scale-vector
X (lambda (s)
X (element-wise (lambda (x) (* x s)))))
X
X(define map-streams
X (lambda (f s)
X (cons (f (head s))
X (delay (map-streams f (tail s))))))
X
X(define head car)
X(define tail
X (lambda (stream) (force (cdr stream))))
X
X(define damped-oscillator
X (lambda (R L C)
X (lambda (state)
X (let ((Vc (vector-ref state 0))
X (Il (vector-ref state 1)))
X (vector (- 0 (+ (/ Vc (* R C)) (/ Il C)))
X (/ Vc L))))))
X
X(define the-states
X (integrate-system
X (damped-oscillator 10000 1000 0.001)
X '#(1 0)
X 0.01))
X
X(print the-states)
X; (print (tail the-states))
END_OF_tst/runge-kutta
if test 1755 -ne `wc -c <tst/runge-kutta`; then
echo shar: \"tst/runge-kutta\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/sqrt -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/sqrt\"
else
echo shar: Extracting \"tst/sqrt\" \(431 characters\)
sed "s/^X//" >tst/sqrt <<'END_OF_tst/sqrt'
X;;; -*-Scheme-*-
X
X(define (sqrt x)
X (define (good-enough? guess)
X (< (abs (- (square guess) x)) 0.001))
X (define (improve guess)
X (average guess (/ x guess)))
X (define (sqrt-iter guess)
X (if (good-enough? guess)
X guess
X (sqrt-iter (improve guess))))
X (sqrt-iter 1))
X
X(define (square x) (* x x))
X(define (average x y) (/ (+ x y) 2))
X(define (abs x) (if (negative? x) (- x) x))
X
X(print (sqrt 2))
X(print (sqrt 4))
END_OF_tst/sqrt
if test 431 -ne `wc -c <tst/sqrt`; then
echo shar: \"tst/sqrt\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/unify -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/unify\"
else
echo shar: Extracting \"tst/unify\" \(1287 characters\)
sed "s/^X//" >tst/unify <<'END_OF_tst/unify'
X;;; -*-Scheme-*-
X
X(define unify)
X
X(letrec
X ((occurs?
X (lambda (u v)
X (and (pair? v)
X (define (f l)
X (and l
X (or (eq? u (car l))
X (occurs? u (car l))
X (f (cdr l)))))
X (f (cdr v)))))
X (sigma
X (lambda (u v s)
X (lambda (x)
X (define (f x)
X (if (symbol? x)
X (if (eq? x u) v x)
X (cons (car x) (map f (cdr x)))))
X (f (s x)))))
X (try-subst
X (lambda (u v s ks kf)
X (let ((u (s u)))
X (if (not (symbol? u))
X (uni u v s ks kf)
X (let ((v (s v)))
X (cond
X ((eq? u v) (ks s))
X ((occurs? u v) (kf "loop"))
X (else (ks (sigma u v s)))))))))
X (uni
X (lambda (u v s ks kf)
X (cond
X ((symbol? u) (try-subst u v s ks kf))
X ((symbol? v) (try-subst v u s ks kf))
X ((and (eq? (car u) (car v))
X (= (length u) (length v)))
X (define (f u v s)
X (if (null? u)
X (ks s)
X (uni (car u)
X (car v)
X s
X (lambda (s) (f (cdr u) (cdr v) s))
X kf)))
X (f (cdr u) (cdr v) s))
X (else (kf "clash"))))))
X (set! unify
X (lambda (u v)
X (uni u
X v
X (lambda (x) x)
X (lambda (s) (s u))
X (lambda (msg) msg)))))
X
X(print (unify 'x 'y))
X(print (unify '(f x y) '(g x y)))
X(print (unify '(f x (h)) '(f (h) y)))
X(print (unify '(f (g x) y) '(f y x)))
X(print (unify '(f (g x) y) '(f y (g x))))
END_OF_tst/unify
if test 1287 -ne `wc -c <tst/unify`; then
echo shar: \"tst/unify\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/mondo -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/mondo\"
else
echo shar: Extracting \"tst/mondo\" \(240 characters\)
sed "s/^X//" >tst/mondo <<'END_OF_tst/mondo'
X;;; -*-Scheme-*-
X
X(let ((k (call-with-current-continuation (lambda (c) c))))
X (display 1)
X (call-with-current-continuation (lambda (c) (k c)))
X (display 2)
X (call-with-current-continuation (lambda (c) (k c)))
X (display 3)
X (newline))
END_OF_tst/mondo
if test 240 -ne `wc -c <tst/mondo`; then
echo shar: \"tst/mondo\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/fix -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/fix\"
else
echo shar: Extracting \"tst/fix\" \(567 characters\)
sed "s/^X//" >tst/fix <<'END_OF_tst/fix'
X;;; -*-Scheme-*-
X;;;
X;;; from BYTE Feb. 88 page 208
X
X(define (fixed-point f initial-value)
X (define epsilon 1.0e-10)
X (define (close-enough? v1 v2)
X (< (abs (- v1 v2)) epsilon))
X (define (loop value)
X (let ((next-value (f value)))
X (if (close-enough? value next-value)
X next-value
X (loop next-value))))
X (loop initial-value))
X
X(define (average-damp f)
X (lambda (x)
X (average x (f x))))
X
X(define (average x y)
X (/ (+ x y) 2))
X
X(define (sqrt x)
X (fixed-point (average-damp (lambda (y) (/ x y)))
X 1))
X
X(print (sqrt 2))
X(print (sqrt 4))
X
X
END_OF_tst/fix
if test 567 -ne `wc -c <tst/fix`; then
echo shar: \"tst/fix\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/ramanujan -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/ramanujan\"
else
echo shar: Extracting \"tst/ramanujan\" \(451 characters\)
sed "s/^X//" >tst/ramanujan <<'END_OF_tst/ramanujan'
X;;; -*-Scheme-*-
X
X(define (1/pi)
X (define (step n)
X (/ (* (fact (* 4 n)) (+ 1103 (* 26390 n)))
X (* (expt (fact n) 4) (expt 396 (* 4 n)))))
X (* (/ (sqrt 8) 9801)
X (step 0)))
X
X(define (fact n)
X (let f ((i n) (a 1))
X (if (zero? i)
X a
X (f (- i 1) (* a i)))))
X
X(define (square x) (* x x))
X
X(define (expt b n)
X (cond ((= n 0) 1)
X ((even? n) (square (expt b (/ n 2))))
X (else (* b (expt b (- n 1))))))
X
X(print (/ 1 (1/pi)))
END_OF_tst/ramanujan
if test 451 -ne `wc -c <tst/ramanujan`; then
echo shar: \"tst/ramanujan\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/Y -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/Y\"
else
echo shar: Extracting \"tst/Y\" \(5985 characters\)
sed "s/^X//" >tst/Y <<'END_OF_tst/Y'
X; Date: 15 Nov 88 23:03:24 GMT
X; From: uoregon!markv at beaver.cs.washington.edu (Mark VandeWettering)
X; Organization: University of Oregon, Computer Science, Eugene OR
X; Subject: The Paradoxical Combinator -- Y (LONG)
X;
X; Alternatively entitled:
X; "Y? Why Not?" :-)
X;
X; The discussion that has been going on in regards to the Y combinator as
X; the basic operation in implementing recursive functions are interesting.
X; The practical tests that people have made have shown that the Y
X; combinator is orders of magnitude slower for implementing recursion than
X; directly compiling it.
X;
X; This is true for Scheme. I hold that for an interesting set of
X; languages, (lazy languages) that this result will not necessarily hold.
X;
X; The problem with Y isn't its complexity, it is the fact that it is an
X; inherently lazy operation. Any implementation in Scheme is clouded by
X; the fact that Scheme is an applicative order evaluator, while Y prefers
X; to be evaluated in normal order.
X;
X;
X (define Y
X (lambda (g)
X ((lambda (h) (g (lambda (x) ((h h) x))))
X (lambda (h) (g (lambda (x) ((h h) x)))))))
X;
X (define fact
X (lambda (f)
X (lambda (n)
X (if (= n 1)
X 1
X (* n (f (- n 1)))))))
X;
X;
X; Evaluating (Y fact) 2 results in the following operations in
X; Scheme:
X;
X; The argument is (trivially) evaluated, and returns two.
X; (Y fact) must be evaluated. What is it? Y and fact each evaluate
X; to closures. When applied, Y binds g to fact, and executes the
X; body.
X;
X; The body is an application of a closure to another closure. The
X; operator binds h to the operand, and executes its body which....
X;
X; Evaluates (g (lambda (x) ((h h) x))). The operand is a closure,
X; which gets built and then returns. g evaluates to fact. We
X; substitute the closure (lambda (x) ((h h) x)) in for the function
X; f in the definition of fact, giving...
X;
X; (lambda (n)
X; (if (= n 1)
X; 1
X; (* n ((lambda (x) ((h h) x)) (- n 1)))))
X;
X; Which we return as the value of (Y fact). When we apply this to 2, we get
X;
X; (* 2 ((lambda (x) ((h h) x)) 1))
X;
X; We then have to evaluate
X; ((lambda (x) ((h h) x)) 1)
X;
X; or
X; ((h h) 1)
X;
X; But remembering that h was (lambda (h) (g (lambda (x) ((h h) x)))),
X; we have
X;
X; (((lambda (h) (g (lambda (x) ((h h) x))))
X; (lambda (h) (g (lambda (x) ((h h) x)))))
X; 1) ....
X;
X; So, we rebind h to be the right stuff, and evaluate the body, which is
X;
X; ((g (lambda (x) ((h h) x))) 1)
X;
X; Which by the definition of g (still == fact) is just 1.
X;
X; (* 2 1) = 2.
X;
X; ########################################################################
X;
X; Summary: If you didn't follow this, performing this evaluation
X; was cumbersome at best. As far as compiler or interpreter is
X; concerned, the high cost of evaluating this function is related
X; to two different aspects:
X;
X; It is necessary to create "suspended" values. These suspended
X; values are represented as closures, which are in general heap
X; allocated and expensive.
X;
X; For every level of recursion, new closures are created (h gets
X; rebound above). While this could probably be optimized out by a
X; smart compiler, it does seem like the representation of suspended
X; evaluation by lambdas is inefficient.
X;
X;
X; ########################################################################
X;
X; You can try to figure out how all this works. It is complicated, I
X; believe I understand it. The point in the derivation above is that in
X; Scheme, to understand how the implementation of Y works, you have to
X; fall back on the evaluation mechanism of Scheme. Suspended values must
X; be represented as closures. It is the creation of these closures that
X; cause the Scheme implementation to be slow.
X;
X; If one wishes to abandon Scheme (or at least applicative order
X; evaluators of Scheme) one can typically do much better. My thesis work
X; is in graph reduction, and trying to understand better the issues having
X; to do with implementation.
X;
X; In graph reduction, all data items (evaluated and unevaluated) have the
X; same representation: as graphs in the heap. We choose to evaluate using
X; an outermost, leftmost strategy. This allows the natural definition of
X; (Y h) = (h (Y h)) to be used. An application node of the form:
X;
X; @
X; / \
X; / \
X; Y h
X;
X; can be constructed in the obvious way:
X; @
X; / \
X; / \
X; h @
X; / \
X; / \
X; Y h
X;
X; costing one heap allocation per level of recursion, which is
X; certainly cheaper than the multiple allocations of scheme
X; closures above. More efficiently, we might choose to implement
X; it using a "knot tying" version:
X;
X;
X; /\
X; / \
X; @ |
X; / \ /
X; / \/
X; h
X;
X; Which also works quite well. Y has been eliminated, and will
X; cause no more reductions.
X;
X; The basic idea is somehow that recursion in functional languages
X; is analogous to cycles in the graph in a graph reduction engine.
X; Therefore, the Y combinator is a specific "textual" indicator of
X; the graph.
X;
X; The G-machine (excellently described in Peyton Jones' book "The
X; Implementation of Functional Programming Languages") also
X; described the Y combinator as being efficient. He chose letrecs
X; as being a primitive in the extended lambda calculus. His
X; methodology behind compiling these recursive definitions was
X; basically to compile fixed code which directly built these cyclic
X; structures, rather than having them built at runtime.
X;
X; I think (and my thesis work is evolving into this kind of
X; argument) that Y is overlooked for trivial reasons. Partial
X; evaluation and smarter code generation could make an SK based
X; compiler generate code which is equal in quality to that produced
X; by supercombinator based compilation.
X;
X;
X; This is too long already, ciao for now.
X;
X; Mark VandeWettering
X
X(print ((Y fact) 10))
END_OF_tst/Y
if test 5985 -ne `wc -c <tst/Y`; then
echo shar: \"tst/Y\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/cell -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/cell\"
else
echo shar: Extracting \"tst/cell\" \(563 characters\)
sed "s/^X//" >tst/cell <<'END_OF_tst/cell'
X;;; -*-Scheme-*-
X
X(define (make-cell)
X (call-with-current-continuation
X (lambda (return-from-make-cell)
X (letrec ((state
X (call-with-current-continuation
X (lambda (return-new-state)
X (return-from-make-cell
X (lambda (op)
X (case op
X ((set)
X (lambda (value)
X (call-with-current-continuation
X (lambda (return-from-access)
X (return-new-state
X (list value return-from-access))))))
X ((get) (car state)))))))))
X ((cadr state) 'done)))))
X
X(define c (make-cell))
X(print ((c 'set) 99))
X(print (c 'get))
END_OF_tst/cell
if test 563 -ne `wc -c <tst/cell`; then
echo shar: \"tst/cell\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/co -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/co\"
else
echo shar: Extracting \"tst/co\" \(2682 characters\)
sed "s/^X//" >tst/co <<'END_OF_tst/co'
X; -*-Scheme-*-
X
X(require 'cscheme)
X
X(define (displayLine . someArgs)
X (for-each
X (lambda (aTerm) (display aTerm) (display " "))
X someArgs)
X (newline))
X
X(define (Monitor)
X
X (define stopAtMonitorLevel #f)
X (define clock 0)
X (define stopTime 0)
X (define processIndicators ())
X
X (define (setInitialProcessState! aContinuation)
X (set! processIndicators
X (cons (list 0 aContinuation) processIndicators))
X (stopAtMonitorLevel #f))
X
X (define (startSimulation! aDuration)
X (set! stopTime aDuration)
X (if (not (null? processIndicators))
X (let ((firstIndicatorOnList (car processIndicators)))
X (set! processIndicators
X (remove firstIndicatorOnList processIndicators))
X (resumeSimulation! firstIndicatorOnList))
X (displayLine "*** no active process recorded!")))
X
X (define (resumeSimulation! aProcessState)
X (set! processIndicators
X (cons aProcessState processIndicators))
X (let ((nextProcessState aProcessState))
X (for-each (lambda (aStatePair)
X (if (< (car aStatePair) (car nextProcessState))
X (set! nextProcessState aStatePair)))
X processIndicators)
X (let ((time (car nextProcessState))
X (continuation (cadr nextProcessState)))
X (set! processIndicators
X (remove nextProcessState processIndicators))
X (if (<= time stopTime)
X (begin (set! clock time)
X (continuation #f))
X (begin (displayLine "*** simulation stops at:" clock)
X (stopAtMonitorLevel #f))))))
X
X (define (dispatch aMessage . someArguments)
X (cond ((eq? aMessage 'initialize)
X (setInitialProcessState! (car someArguments)))
X ((eq? aMessage 'startSimulation)
X (startSimulation! (car someArguments)))
X ((eq? aMessage 'proceed)
X (resumeSimulation! (car someArguments)))
X ((eq? aMessage 'time)
X clock)
X ((eq? aMessage 'processIndicators)
X processIndicators)
X (else
X "Sorry, I don't know how to do this!")))
X
X (call-with-current-continuation
X (lambda (anArg)
X (set! stopAtMonitorLevel anArg)))
X dispatch)
X
X
X
X
X(define (Tourist aName aMonitor)
X (call-with-current-continuation
X (lambda (anArg)
X (aMonitor 'initialize anArg)))
X (displayLine aName "starts at" (aMonitor 'time))
X (while #t
X (displayLine aName "walks on at" (aMonitor 'time))
X (call-with-current-continuation
X (lambda (anArg)
X (aMonitor 'proceed
X (list (+ (aMonitor 'time) 1) anArg))))
X (displayLine aName "arrives at new attraction at" (aMonitor 'time))
X (call-with-current-continuation
X (lambda (anArg)
X (aMonitor 'proceed
X (list (+ (aMonitor 'time) 2)
X anArg))))))
X
X
X(define Gallery (Monitor))
X
X(Tourist 'Jane Gallery)
X(Tourist 'Bruce Gallery)
X
X(Gallery 'startSimulation 5)
END_OF_tst/co
if test 2682 -ne `wc -c <tst/co`; then
echo shar: \"tst/co\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test ! -d lib ; then
echo shar: Creating directory \"lib\"
mkdir lib
fi
if test ! -d lib/xlib ; then
echo shar: Creating directory \"lib/xlib\"
mkdir lib/xlib
fi
if test ! -d lib/xlib/examples ; then
echo shar: Creating directory \"lib/xlib/examples\"
mkdir lib/xlib/examples
fi
if test -f lib/xlib/examples/lines -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/xlib/examples/lines\"
else
echo shar: Extracting \"lib/xlib/examples/lines\" \(1096 characters\)
sed "s/^X//" >lib/xlib/examples/lines <<'END_OF_lib/xlib/examples/lines'
X;;; -*-Scheme-*-
X
X(require 'xlib)
X
X(define (lines)
X (let*
X ((dpy (open-display))
X (black (black-pixel dpy)) (white (white-pixel dpy))
X (win (make-window (parent (display-root-window dpy))
X (width 400) (height 400)
X (background-pixel white)
X (event-mask '(exposure button-press
X enter-window leave-window))))
X (gc (make-gcontext (window win) (background white)
X (foreground black)))
X (draw
X (lambda (inc)
X (clear-window win)
X (with win
X (let ((width (window-width win))
X (height (window-height win)))
X (do ((x 0 (+ x inc))) ((> x width))
X (draw-line win gc x 0 (- width x) height))
X (do ((y height (- y inc))) ((< y 0))
X (draw-line win gc 0 y width (- height y))))))))
X
X (map-window win)
X (unwind-protect
X (handle-events dpy
X (button-press
X (lambda args #t))
X (expose
X (lambda args
X (draw 2)
X #f))
X ((enter-notify leave-notify)
X (lambda (e . args)
X (set-window-border-pixel! win
X (if (eq? e 'enter-notify) white black))
X #f)))
X (close-display dpy))))
X
X(lines)
END_OF_lib/xlib/examples/lines
if test 1096 -ne `wc -c <lib/xlib/examples/lines`; then
echo shar: \"lib/xlib/examples/lines\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/xlib/examples/hello -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/xlib/examples/hello\"
else
echo shar: Extracting \"lib/xlib/examples/hello\" \(1027 characters\)
sed "s/^X//" >lib/xlib/examples/hello <<'END_OF_lib/xlib/examples/hello'
X;;; -*-Scheme-*-
X
X(require 'xlib)
X
X(define (hello-world)
X (let* ((dpy (open-display))
X (black (black-pixel dpy)) (white (white-pixel dpy))
X (font (open-font dpy "*-new century schoolbook-bold-r*24*"))
X (text (translate-text "Hello world!"))
X (width (+ (text-width font text '1-byte)))
X (height (+ (max-char-ascent font) (max-char-descent font)))
X (win (make-window (parent (display-root-window dpy))
X (width width) (height height)
X (background-pixel white)
X (event-mask '(exposure button-press))))
X (gc (make-gcontext (window win) (background white)
X (foreground black) (font font))))
X (map-window win)
X (unwind-protect
X (handle-events dpy
X (button-press
X (lambda ignore #t))
X (expose
X (lambda ignore
X (let ((x (truncate (/ (- (window-width win) width) 2)))
X (y (truncate (/ (- (+ (window-height win)
X (max-char-ascent font))
X (max-char-descent font)) 2))))
X (draw-poly-text win gc x y text '1-byte)) #f)))
X (close-display dpy))))
X
X(hello-world)
END_OF_lib/xlib/examples/hello
if test 1027 -ne `wc -c <lib/xlib/examples/hello`; then
echo shar: \"lib/xlib/examples/hello\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/xlib/examples/poly -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/xlib/examples/poly\"
else
echo shar: Extracting \"lib/xlib/examples/poly\" \(976 characters\)
sed "s/^X//" >lib/xlib/examples/poly <<'END_OF_lib/xlib/examples/poly'
X;;; -*-Scheme-*-
X
X(require 'xlib)
X
X(define (poly)
X (let* ((dpy (open-display))
X (black (black-pixel dpy)) (white (white-pixel dpy))
X (width 400) (height 400)
X (win (make-window (parent (display-root-window dpy))
X (width width) (height height)
X (background-pixel white) (event-mask '(exposure))))
X (gc (make-gcontext (window win) (function 'xor)
X (background white) (foreground black)))
X (l '(#f #f #f))
X (rand (lambda (x) (modulo (random) x))))
X (map-window win)
X (handle-events dpy
X (else (lambda args
X (set! width (window-width win))
X (set! height (window-height win)) #t)))
X (unwind-protect
X (let loop ((n 0))
X (if (= n 200)
X (begin
X (clear-window win)
X (display-wait-output dpy #f)
X (set! n 0)))
X (fill-polygon win gc
X (list->vector
X (map (lambda (x) (cons (rand width) (rand height))) l))
X #f 'convex)
X (loop (1+ n)))
X (close-display dpy))))
X
X(poly)
END_OF_lib/xlib/examples/poly
if test 976 -ne `wc -c <lib/xlib/examples/poly`; then
echo shar: \"lib/xlib/examples/poly\" unpacked with wrong size!
fi
# end of overwriting check
fi
echo shar: End of archive 8 \(of 14\).
cp /dev/null ark8isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 14 archives.
rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0
More information about the Comp.sources.misc
mailing list