[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
TI Scheme functions for MIT C-Scheme - 1 of 3
This is a package of functions and macros to make MIT C-Scheme work with
TI Scheme code. This package has some nice features such as
auto-loading, and it allows you to use the TI Scheme manual, which is
worth buying a copy of PC Scheme for on its own. Also included is Kent
Dybvig's extend-syntax, and TI's SCOOPS. See the README file for a
(meagre) description of what it does and doesn't do.
It is incomplete and is still being worked on; I will post revisions to
the net as new versions are finished. You may wish to keep a virgin
copy of this around so that I can send out official patches for
application by Larry Wall's patch program. Similarly, you may wish to
send me context diffs of bugs and improvements, relative to the virgin
distribution.
Snip here and feed to sh.
Mike.
#--------------------------------CUT HERE-------------------------------------
#! /bin/sh
#
# This is a shell archive. Save this into a file, edit it
# and delete all lines above this comment. Then give this
# file to sh by executing the command "sh file". The files
# will be extracted into the current directory owned by
# you with default permissions.
#
# The files contained herein are:
#
# -rw-r--r-- 1 mike 4392 Mar 30 14:35 README
# -rw-r----- 1 mike 2451 Mar 30 14:35 auto-load.scm
# -rw-r--r-- 1 mike 309 Mar 30 14:35 compile-the-files.scm
# -rw-r----- 1 mike 4044 Mar 30 14:35 escape.scm
# -rw-r--r-- 1 mike 10153 Mar 30 14:35 extend.scm
# -rw-r----- 1 mike 1013 Mar 30 14:35 graphics.scm
# -rw-r----- 1 mike 668 Mar 30 14:35 parser-escape.scm
# -rw-r----- 1 mike 4788 Mar 30 14:35 scoops.doc
#
echo 'x - README'
if test -f README; then echo 'shar: not overwriting README'; else
sed 's/^X//' << '________This_Is_The_END________' > README
X
X TI PC COMPATIBILITY PACKAGE
X
X
X Version 1.0
X March 1989
X
X For MIT C-Scheme 6.2.2
X
XThis directory contains a set of files to make MIT C-Scheme behave like
XTI's PC-Scheme. It is incomplete and is still being worked on; I will post
Xrevisions to the net as new versions are finished. This package has some
Xnice features such as auto-loading, and it allows you to use the TI Scheme
Xmanual, which is worth buying a copy of PC Scheme for on its own.
X
XMost of the code is in the file "ti.scm". Look through that file
Xfor an idea of what has been added or replaced (use the source, Luke!).
XIn the true MIT tradition, it is very sparsely commented.
X
XTo use these modifications, set the environment variable TISCHEME to
Xthe directory where the files are located
X
X setenv TISCHEME <this-directory>
X
XAlso set the environment variable SCHEME to the directory where the
XMIT C-Scheme runtime files are located
X
X setenv SCHEME /usr/local/src/scheme/runtime
X
XAnd finally, include the line
X
X (load "$TISCHEME/ti")
X
Xin your ~/.scheme.init initialization file.
X
XThe compile all of the files, cd to the $TISCHEME directory, start
Xup a copy of C-Scheme (version 6.1 or 6.2), and
X
X (load "compile-the-files.scm")
X
XNotes:
X-----
X
XThe auto-loading sometimes tries to auto-load define variables, if the same
Xvariable name is on the auto-load list. The net result is usually harmless.
XIf I can figure out a better way of auto-loading, I will post it.
X
XThe TI Scheme MACRO form has been renamed to TI-MACRO, to avoid conflict
Xwith the MIT macro form.
X
XKent Dybvig's extend-syntax has been included, in an updated form from
Xwhat is included with TI-Scheme 3.02. The reference manual for this is
X
X The Scheme Programming Language
X R. Kent Dybvig
X Prentice-Hall, Englewood Cliffs, New Jersey, 07632 (1987)
X Library of Congress Catalog Card Number 86-63489
X
XAs it is not a part of the TI Scheme dialect per se, it is not set to
Xautoload. Do (load "extend.scm") to load this.
X
XThe SCOOPS code appears to work, but I have not tested it much.
XThere are some notes previously distributed on the net in scoops.doc,
Xbut the best reference is Chapter 5 of the TI-Scheme Reference Manual.
X
XThe SORT! will only destructively sort vectors, although it accepts lists.
X
XThe parser escape for |funny atoms| is implemented only for the reader.
XDisplaying a funny atom will not result in |funny atom| as it should.
X
XNot Yet Done:
X------------
X
XThere a number of functions that have not been converted yet.
XMost of these have been defined to raise an error with the message
X
X Not implemented yet.
X
XAmong the functions that are missing include:
X
X ALIAS (I can't figure out the right incantation)
X ASSERT
X GET-FILE-POSITION (Needs support in C for opening files with append)
X (SET! (VECTOR-REF vector n) value) (not implemented yet)
X (SET! (FLUID var) value) (not implemented yet)
X SYNTAX (Conflicts with the MIT syntax)
X
XThe windows code will have to wait until the next release of C-Scheme,
Xwhich should have some windowing code to support Edwin:
X
X CURRENT-COLUMN
X EDWIN
X FRESH-LINE
X WINDOW-CLEAR
X WINDOW-DELETE
X WINDOW-GET-ATTRIBUTE
X WINDOW-GET-CURSOR
X WINDOW-GET-POSITION
X WINDOW-GET-SIZE
X WINDOW-POPUP
X WINDOW-POPUP-DELETE
X WINDOW-RESTORE-CONTENTS
X WINDOW-SAVE-CONTENTS
X WINDOW-SET-ATTRIBUTE!
X WINDOW-SET-CURSOR!
X WINDOW-SET-POSITION!
X WINDOW-SET-SIZE!
X WINDOW?
X
XEngines have not been implemented, though I may look at making kwh's
Xtasks act like engines:
X
X MAKE-ENGINE
X ENGINE-RETURN
X
XNone of the graphics have been implemented. Maybe someone familiar with the
XC-Scheme Xlib code could make something...
X
X CLEAR-GRAPHICS
X CLEAR-POINT
X DRAW-BOX-TO
X DRAW-FILLED-BOX-TO
X DRAW-LINE-TO
X DRAW-POINT
X GET-PEN-COLOR
X GET-VIDEO-MODE
X *GRAPHICS-COLORS*
X IS-POINT-ON?
X POINT-COLOR
X POSITION-PEN
X
XThe line editor hasn't been ported, but in these days od Gnu, does anyone
Xreall care?
X
X EDIT
X
XPlease send bug reports to me, and any unimplemented functions that you
Xmay have. If possible, keep a virgin copy of this distribution, and send
Xme context diffs to apply by Larry Wall's patch program. I will distribute
Xminor version patches in this form.
X
X
XMike Clarkson mike@ists.ists.ca
XInstitute for Space and Terrestrial Science mike@ists.uucp
XYork University, North York, Ontario, uunet!mnetor!yunexus!ists!mike
XCANADA M3J 1P3 +1 (416) 736-5611
________This_Is_The_END________
if test `wc -l < README` -ne 146; then
echo 'shar: README was damaged during transit (should have been 146 lines)'
fi
fi ; : end of overwriting check
echo 'x - auto-load.scm'
if test -f auto-load.scm; then echo 'shar: not overwriting auto-load.scm'; else
sed 's/^X//' << '________This_Is_The_END________' > auto-load.scm
X(declare (usual-integrations))
X
X(define (autoload-from-file filename variables #!optional environment)
X (if (unassigned? environment)
X (set! environment (the-environment)))
X (for-each (lambda (var)
X (2d-put! var 'AUTOLOAD (cons filename environment)))
X variables)
X variables)
X
X(in-package syntaxer-package
X
X (define (syntax? item #!optional table)
X (if (unassigned? table) (set! table *rep-current-syntax-table*))
X (syntax-table-ref table item))
X
X (define (autoload variable-name)
X (if (and (symbol? variable-name) (2d-get variable-name 'AUTOLOAD))
X (do-autoload variable-name)))
X
X (define (do-autoload name)
X (if (symbol? name)
X (let ((file-env (2d-get name 'autoload)))
X (if file-env
X (let ((file (car file-env))
X (env (cdr file-env)))
X ; remove it just in case it doesn't define it.
X ; or in case it references itself
X (remove-from-autoloads file)
X (display "Autoloading from file ") (display file)
X (display " to define ") (display name) (newline)
X;; (set! env *rep-current-environment*) ; for the moment
X (load file env)
X (if (and (lexical-unreferenceable? env name)
X (not (syntax? name syntax-table)))
X (begin
X (beep)
X (display "Autoloading failed to define ") (display name)
X (display " in environment ") (display env)
X (newline))
X (begin
X (display "Autoloading done.") (newline))))))))
X
X(define (list-all-autoloads)
X (2d-get-alist-y 'autoload))
X
X (define (remove-from-autoloads filename)
X "Remove all autoloads associated with this file"
X (for-each
X (lambda (al)
X (2d-remove! (car al) 'AUTOLOAD))
X (list-transform-positive
X (list-all-autoloads)
X (lambda (elt)
X (string-ci=? (cadr elt) filename)))))
X
X;; Alter the syntaxer to check for autoloading
X;; modify syntax-expression to autoload if neccesary
X
X (define (syntax-expression expression)
X (if (and (symbol? expression)
X (lexical-unreferenceable? *rep-current-environment* expression)
X (not (syntax? expression syntax-table)))
X (autoload expression))
X (cond ((pair? expression)
X (let ((quantum (syntax-table-ref syntax-table (car expression))))
X (if quantum
X (fluid-let ((saved-keyword (car expression)))
X (quantum expression))
X (make-combination (syntax-expression (car expression))
X (syntax-expressions (cdr expression))))))
X ((symbol? expression)
X (make-variable expression))
X (else
X expression))))
X
________This_Is_The_END________
if test `wc -l < auto-load.scm` -ne 76; then
echo 'shar: auto-load.scm was damaged during transit (should have been 76 lines)'
fi
fi ; : end of overwriting check
echo 'x - compile-the-files.scm'
if test -f compile-the-files.scm; then echo 'shar: not overwriting compile-the-files.scm'; else
sed 's/^X//' << '________This_Is_The_END________' > compile-the-files.scm
X;; The order of these file is significant
X
X(sf "auto-load.scm")
X(sf "escape.scm")
X
X(load "ti.scm")
X(sf "parser-escape.scm")
X
X(sf "sort.scm")
X
X;; SCOOPS
X(sf "scoops.scm")
X
X;; Files of not implimented stuff.
X(sf "graphics.scm")
X(sf "window.scm")
X
X;; The main file that loads or auto-loads the rest
________This_Is_The_END________
if test `wc -l < compile-the-files.scm` -ne 18; then
echo 'shar: compile-the-files.scm was damaged during transit (should have been 18 lines)'
fi
fi ; : end of overwriting check
echo 'x - escape.scm'
if test -f escape.scm; then echo 'shar: not overwriting escape.scm'; else
sed 's/^X//' << '________This_Is_The_END________' > escape.scm
X(declare (usual-integrations))
X
X(let-syntax ((define-primitives
X (macro names
X `(BEGIN ,@(map (lambda (name)
X `(LOCAL-ASSIGNMENT
X SYSTEM-GLOBAL-ENVIRONMENT
X ',name
X ,(make-primitive-procedure name)))
X names)))))
X (define-primitives
X make-char char-code char-bits char->integer integer->char char->ascii
X char-ascii? ascii->char char-upcase char-downcase))
X
X(let ()
X
X (define char-type
X (microcode-type 'CHARACTER))
X
X (define 0-code (char-code (ascii->char #x30)))
X (define upper-a-code (char-code (ascii->char #x41)))
X (define lower-a-code (char-code (ascii->char #x61)))
X (define space-char (ascii->char #x20))
X (define hyphen-char (ascii->char #x2D))
X (define backslash-char (ascii->char #x5C))
X
X (define named-codes
X `(("Backspace" . #x08)
X ("Tab" . #x09)
X ("Linefeed" . #x0A)
X ("VT" . #x0B)
X ("Page" . #x0C)
X ("Return" . #x0D)
X ("Call" . #x1A)
X ("Altmode" . #x1B)
X ("Escape" . #x1B)
X ("Backnext" . #x1F)
X ("Space" . #x20)
X ("Rubout" . #x7F)
X ))
X
X (define named-bits
X `(("C" . #o01)
X ("Control" . #o01)
X ("M" . #o02)
X ("Meta" . #o02)
X ("S" . #o04)
X ("Super" . #o04)
X ("H" . #o10)
X ("Hyper" . #o10)
X ("T" . #o20)
X ("Top" . #o20)
X ))
X
X (define (-map-> alist string start end)
X (define (loop entries)
X (and (not (null? entries))
X (let ((key (caar entries)))
X (if (substring-ci=? string start end
X key 0 (string-length key))
X (cdar entries)
X (loop (cdr entries))))))
X (loop alist))
X
X (define (<-map- alist n)
X (define (loop entries)
X (and (not (null? entries))
X (if (= n (cdar entries))
X (caar entries)
X (loop (cdr entries)))))
X (loop alist))
X
X (set! char?
X (named-lambda (char? object)
X (primitive-type? char-type object)))
X
X (set! name->char
X (named-lambda (name->char string)
X (let ((end (string-length string))
X (bits '()))
X (define (loop start)
X (let ((left (- end start)))
X (cond ((zero? left)
X (error "Missing character name"))
X ((= left 1)
X (let ((char (string-ref string start)))
X (if (char-graphic? char)
X (char-code char)
X (error "Non-graphic character" char))))
X (else
X (let ((hyphen (substring-find-next-char string start end
X hyphen-char)))
X (if (not hyphen)
X (name->code string start end)
X (let ((bit (-map-> named-bits string start hyphen)))
X (if (not bit)
X (name->code string start end)
X (begin (if (not (memv bit bits))
X (set! bits (cons bit bits)))
X (loop (1+ hyphen)))))))))))
X (let ((code (loop 0)))
X (make-char code (apply + bits))))))
X
X (define (name->code string start end)
X (if (substring-ci=? string start end "Newline" 0 7)
X (char-code char:newline)
X (or (-map-> named-codes string start end)
X (error "Unknown character name" (substring string start end)))))
X
X (set! char->name
X (named-lambda (char->name char #!optional slashify?)
X (if (unassigned? slashify?) (set! slashify? false))
X (define (loop weight bits)
X (if (zero? bits)
X (let ((code (char-code char)))
X (let ((base-char (code->char code)))
X (cond ((<-map- named-codes code))
X ((and slashify?
X (not (zero? (char-bits char)))
X (or (char=? base-char backslash-char)
X (char-set-member? (access atom-delimiters
X parser-package)
X base-char)))
X (string-append "\\" (char->string base-char)))
X ((char-graphic? base-char)
X (char->string base-char))
X (else
X (string-append "<code "
X (write-to-string code)
X ">")))))
X (let ((qr (integer-divide bits 2)))
X (let ((rest (loop (* weight 2) (integer-divide-quotient qr))))
X (if (zero? (integer-divide-remainder qr))
X rest
X (string-append (or (<-map- named-bits weight)
X (string-append "<bit "
X (write-to-string weight)
X ">"))
X "-"
X rest))))))
X (loop 1 (char-bits char))))
X
X )
________This_Is_The_END________
if test `wc -l < escape.scm` -ne 143; then
echo 'shar: escape.scm was damaged during transit (should have been 143 lines)'
fi
fi ; : end of overwriting check
echo 'x - extend.scm'
if test -f extend.scm; then echo 'shar: not overwriting extend.scm'; else
sed 's/^X//' << '________This_Is_The_END________' > extend.scm
X;;; Copyright (C) 1987 Cadence Research Systems
X;;; Permission to copy this software, in whole or in part, to use this
X;;; software for any lawful noncommercial purpose, and to redistribute
X;;; this software is granted subject to the restriction that all copies
X;;; made of this software must include this copyright notice in full.
X;;; Cadence makes no warranties or representations of any kind, either
X;;; express or implied, including but not limited to implied warranties
X;;; of merchantability or fitness for any particular purpose.
X
X;;; The basic design of extend-syntax is due to Eugene Kohlbecker. See
X;;; "E. Kohlbecker: Syntactic Extensions in the Programming Language Lisp",
X;;; Ph.D. Dissertation, Indiana University, 1986." The structure of "with"
X;;; pattern/value clauses, the method for compiling extend-syntax into
X;;; Scheme code, and the actual implementation are due to Kent Dybvig.
X
X;;; Made available courtesy R. Kent Dybvig
X;;; MacScheme conversion by Jeff De Vries
X;;; note: requires the use of MacScheme Version 1.2 or greater
X
X;;; Skim conversion by Alain Deutsch.
X;;; C-Scheme conversion by Mike Clarkson (mike@ists.ists.ca).
X
X(declare (usual-integrations))
X
X(in-package system-global-environment
X (define (add-syntax! name expander)
X (SYNTAX-TABLE-DEFINE SYSTEM-GLOBAL-SYNTAX-TABLE name expander)
X name)
X )
X
X;;; GENSYM
X;; Make gensym a version of generate-uninterned-symbol that accepts
X;; a number or a string, as well as a symbol as the optional argument
X(define gensym
X (let ((name-counter 0)
X (name-prefix "G"))
X (define (get-number)
X (let ((result name-counter))
X (set! name-counter (1+ name-counter))
X result))
X (named-lambda (gensym #!optional argument)
X (if (not (unassigned? argument))
X (cond ((string? argument)
X (set! name-prefix argument))
X ((symbol? argument)
X (set! name-prefix (symbol->string argument)))
X ((integer? argument)
X (set! name-counter argument))
X (else
X (error "Bad argument: GENSYM"
X argument))))
X (string->uninterned-symbol
X (string-append name-prefix (write-to-string (get-number)))))))
X
X;;; IF
X(set! undefined-conditional-branch '())
X
X;;; MACRO
X(add-syntax! 'TI-MACRO
X (macro (symbol def)
X (let ((var (caadr def))
X (body (cddr def)))
X (display body)
X `(add-syntax!
X ',symbol
X (macro ,var
X (let ((,var (cons ',symbol ,var)))
X ,@body))))))
X
X;;; WHEN
X(add-syntax 'WHEN
X (macro args
X `(if ,(car args)
X (begin ,@(cdr args)))))
X
X;;; UNLESS
X(add-syntax! 'UNLESS
X (macro args
X `(if ,(car args) #t
X (begin ,@(cdr args)))))
X
X
X(define syntax-match?)
X(define andmap)
X
X(define extend-package
X (make-environment
X
X (define (cadadr x) (car (cdr (car (cdr x)))))
X (define (cadddr x) (car (cdr (cdr (cdr x)))))
X (define (cdaddr x) (cdr (car (cdr (cdr x)))))
X
X (set! andmap
X (lambda (p . args)
X ;; use "first-finish" rule
X (let andmap
X ((args args)
X (value #t))
X (if (let any-at-end?
X ((ls args))
X (and (pair? ls)
X (or (not (pair? (car ls)))
X (any-at-end? (cdr ls)))))
X value
X (let ((value (apply p (map car args))))
X (and value (andmap (map cdr args) value)))))))
X
X ;; syntax-match? is used by extend-syntax to choose among clauses and
X ;; to check for syntactic errors. It is also available to the user.
X (set! syntax-match?
X (lambda (keys pat exp)
X (cond
X ((symbol? pat) (if (memq pat keys) (eq? exp pat) #t))
X ((pair? pat)
X (if (equal? (cdr pat) '(...))
X (let f ((lst exp))
X (or (null? lst)
X (and (pair? lst)
X (syntax-match? keys (car pat) (car lst))
X (f (cdr lst)))))
X (and (pair? exp)
X (syntax-match? keys (car pat) (car exp))
X (syntax-match? keys (cdr pat) (cdr exp)))))
X (else (equal? exp pat)))))
X
X (define id list)
X (define id-name car)
X (define id-access cadr)
X (define id-control caddr)
X
X (define loop
X (lambda ()
X (list '())))
X (define loop-ids car)
X (define loop-ids! set-car!)
X
X (define c...rs
X `((car caar . cdar)
X (cdr cadr . cddr)
X (caar caaar . cdaar)
X (cadr caadr . cdadr)
X (cdar cadar . cddar)
X (cddr caddr . cdddr)
X (caaar caaaar . cdaaar)
X (caadr caaadr . cdaadr)
X (cadar caadar . cdadar)
X (caddr caaddr . cdaddr)
X (cdaar cadaar . cddaar)
X (cdadr cadadr . cddadr)
X (cddar caddar . cdddar)
X (cdddr cadddr . cddddr)))
X
X (define add-car
X (lambda (access)
X (let ((x (and (pair? access) (assq (car access) c...rs))))
X (if (not (pair? x))
X `(car ,access)
X `(,(cadr x) ,@(cdr access))))))
X
X (define add-cdr
X (lambda (access)
X (let ((x (and (pair? access) (assq (car access) c...rs))))
X (if (not (pair? x))
X `(cdr ,access)
X `(,(cddr x) ,@(cdr access))))))
X
X (define parse
X (lambda (keys pat acc cntl ids)
X (cond
X ((symbol? pat)
X (if (memq pat keys)
X ids
X (cons (id pat acc cntl) ids)))
X ((pair? pat)
X (if (equal? (cdr pat) '(...))
X (let ((x (gensym)))
X (parse keys (car pat) x (id x acc cntl) ids))
X (parse keys (car pat) (add-car acc) cntl
X (parse keys (cdr pat) (add-cdr acc) cntl ids))))
X (else ids))))
X
X (define gen
X (lambda (keys exp ids loops)
X (cond
X ((symbol? exp)
X (let ((id (lookup exp ids)))
X (if (not id)
X exp
X (begin
X (add-control! (id-control id) loops)
X (list 'UNQUOTE (id-access id))))))
X ((pair? exp)
X (cond
X ((eq? (car exp) 'with)
X (unless (syntax-match? '(with) '(with ((p x) ...) e) exp)
X (error 'extend-syntax "invalid 'with' form" exp))
X (list 'UNQUOTE
X (gen-with
X keys
X (map car (cadr exp))
X (map cadr (cadr exp))
X (caddr exp)
X ids
X loops)))
X ((and (pair? (cdr exp)) (eq? (cadr exp) '...))
X (let ((x (loop)))
X (make-loop
X x
X (gen keys (car exp) ids (cons x loops))
X (gen keys (cddr exp) ids loops))))
X (else
X (let ((a (gen keys (car exp) ids loops))
X (d (gen keys (cdr exp) ids loops)))
X (if (and (pair? d) (eq? (car d) 'UNQUOTE))
X (list a (list 'UNQUOTE-SPLICING (cadr d)))
X (cons a d))))))
X (else exp))))
X
X (define gen-with
X (lambda (keys pats exps body ids loops)
X (if (null? pats)
X (make-quasi (gen keys body ids loops))
X (let ((p (car pats)) (e (car exps)) (g (gensym)))
X `(let ((,g ,(gen-quotes keys e ids loops)))
X (if (syntax-match? '() ',p ,g)
X ,(gen-with
X keys
X (cdr pats)
X (cdr exps)
X body
X (parse '() p g '() ids)
X loops)
X (error ',(car keys)
X "does not fit 'with' pattern"
X '(,g ,p))))))))
X
X (define gen-quotes
X (lambda (keys exp ids loops)
X (cond
X ((syntax-match? '(quote) '(quote x) exp)
X (make-quasi (gen keys (cadr exp) ids loops)))
X ((pair? exp)
X (cons (gen-quotes keys (car exp) ids loops)
X (gen-quotes keys (cdr exp) ids loops)))
X (else exp))))
X
X (define lookup
X (lambda (sym ids)
X (let loop ((ls ids))
X (cond
X ((null? ls) #f)
X ((eq? (id-name (car ls)) sym) (car ls))
X (else (loop (cdr ls)))))))
X
X (define add-control!
X (lambda (id loops)
X (unless (null? id)
X (when (null? loops)
X (error 'extend-syntax "missing ellipsis in expansion"))
X (let ((x (loop-ids (car loops))))
X (unless (memq id x)
X (loop-ids! (car loops) (cons id x))))
X (add-control! (id-control id) (cdr loops)))))
X
X (define make-loop
X (lambda (loop body tail)
X (let ((ids (loop-ids loop)))
X (when (null? ids)
X (error 'extend-syntax "extra ellipsis in expansion"))
X (cond
X ((equal? body (list 'UNQUOTE (id-name (car ids))))
X (if (null? tail)
X (list 'UNQUOTE (id-access (car ids)))
X (cons (list 'UNQUOTE-SPLICING (id-access (car ids)))
X tail)))
X ((and (null? (cdr ids))
X (syntax-match? '(UNQUOTE) '(UNQUOTE (f x)) body)
X (eq? (cadadr body) (id-name (car ids))))
X (let ((x `(map ,(caadr body) ,(id-access (car ids)))))
X (if (null? tail)
X (list 'UNQUOTE x)
X (cons (list 'UNQUOTE-SPLICING x) tail))))
X (else
X (let ((x `(map (lambda ,(map id-name ids) ,(make-quasi body))
X ,@(map id-access ids))))
X (if (null? tail)
X (list 'UNQUOTE x)
X (cons (list 'UNQUOTE-SPLICING x) tail))))))))
X
X (define make-quasi
X (lambda (exp)
X (if (and (pair? exp) (eq? (car exp) 'UNQUOTE))
X (cadr exp)
X (list 'QUASIQUOTE exp))))
X
X (define make-clause
X (lambda (keys cl x)
X (cond
X ((syntax-match? '() '(pat fender exp) cl)
X (let ((pat (car cl)) (fender (cadr cl)) (exp (caddr cl)))
X (let ((ids (parse keys pat x '() '())))
X `((and (syntax-match? ',keys ',pat ,x)
X ,(gen-quotes keys fender ids '()))
X ,(make-quasi (gen keys exp ids '()))))))
X ((syntax-match? '() '(pat exp) cl)
X (let ((pat (car cl)) (exp (cadr cl)))
X (let ((ids (parse keys pat x '() '())))
X `((syntax-match? ',keys ',pat ,x)
X ,(make-quasi (gen keys exp ids '()))))))
X (else
X (error 'extend-syntax "invalid clause" cl)))))
X
X (define make-syntax
X (let ((x (gensym "x")))
X (lambda (keys clauses)
X `(lambda (,x)
X (cond
X ,@(map (lambda (cl) (make-clause keys cl x)) clauses)
X (else
X (error ',(car keys) "invalid syntax" ,x)))))))
X
X (ti-macro extend-syntax
X (lambda (x)
X (cond
X ((and
X (syntax-match?
X '(extend-syntax)
X '(extend-syntax (key1 key2 ...) clause ...)
X x)
X (andmap symbol? (cadr x)))
X (let ((f (make-syntax `(,(caadr x) ,@(cdadr x)) (cddr x))))
X `(ti-macro ,(caadr x) ,f)))
X (else (error 'extend-syntax "invalid syntax" x)))))
X
X (ti-macro extend-syntax/code
X (lambda (x)
X (cond
X ((and
X (syntax-match?
X '(extend-syntax/code)
X '(extend-syntax/code (key1 key2 ...) clause ...)
X x)
X (andmap symbol? `(,(caadr x) ,@(cdadr x))))
X (let ((f (make-syntax `(,(caadr x) ,@(cdadr x)) (cddr x))))
X (if (syntax-match? '() 'proc f)
X `',f
X (error 'extend-syntax/code
X "does not fit 'with' pattern"
X (list f 'proc)))))
X (else (error 'extend-syntax/code "invalid syntax" x)))))
X
X));; end of extend-package
X
________This_Is_The_END________
if test `wc -l < extend.scm` -ne 353; then
echo 'shar: extend.scm was damaged during transit (should have been 353 lines)'
fi
fi ; : end of overwriting check
echo 'x - graphics.scm'
if test -f graphics.scm; then echo 'shar: not overwriting graphics.scm'; else
sed 's/^X//' << '________This_Is_The_END________' > graphics.scm
X(declare (usual-integrations))
X
X;;; CLEAR-GRAPHICS
X(define (clear-graphics x y)
X (not-implimented-yet 'CLEAR-GRAPHICS))
X
X;;; CLEAR-POINT
X(define (clear-point x y)
X (not-implimented-yet 'CLEAR-POINT))
X
X;;; DRAW-BOX-TO
X(define (draw-box-to x y)
X (not-implimented-yet 'DRAW-BOX-TO))
X
X;;; DRAW-FILLED-BOX-TO
X(define (draw-filled-box-to x y)
X (not-implimented-yet 'DRAW-FILLED-BOX-TO))
X
X;;; DRAW-LINE-TO
X(define (draw-line-to x y)
X (not-implimented-yet 'DRAW-LINE-TO))
X
X;;; DRAW-POINT
X(define (draw-point x y)
X (not-implimented-yet 'DRAW-POINT))
X
X;;; GET-PEN-COLOR
X(define (get-pen-color)
X (not-implimented-yet 'GET-PEN-COLOR))
X
X;;; GET-VIDEO-MODE
X(define (get-video-mode)
X (not-implimented-yet 'GET-VIDEO-MODE))
X
X;;; *GRAPHICS-COLORS*
X(define *graphics-colors*)
X
X;;; IS-POINT-ON?
X(define (is-point-on? x y)
X (not-implimented-yet 'IS-POINT-ON?))
X
X
X;;; POINT-COLOR
X(define (point-color)
X (not-implimented-yet 'POINT-COLOR))
X
X;;; POSITION-PEN
X(define (position-pen x y)
X (not-implimented-yet 'POSITION-PEN))
X
________This_Is_The_END________
if test `wc -l < graphics.scm` -ne 50; then
echo 'shar: graphics.scm was damaged during transit (should have been 50 lines)'
fi
fi ; : end of overwriting check
echo 'x - parser-escape.scm'
if test -f parser-escape.scm; then echo 'shar: not overwriting parser-escape.scm'; else
sed 's/^X//' << '________This_Is_The_END________' > parser-escape.scm
X(declare (usual-integrations))
X
X;; Extend the parser to recognize |
X;; This needs more work so that the |'s show on printing.
X
X(in-package parser-package
X
X (define undefined-atom-delimiters
X (char-set #\[ #\] #\{ #\} ))
X
X (define (intern-string-no-coerce! string)
X (string->symbol string))
X
X (define-char #\|
X (let ((delimiters (char-set #\| #\\)))
X (lambda ()
X (define (loop string)
X (if (char=? #\| (read-char))
X string
X (string-append string
X (char->string (read-char))
X (loop (read-string delimiters)))))
X (discard-char)
X (intern-string-no-coerce! (loop (read-string delimiters))))))
X
X;; end in-package parser-package
________This_Is_The_END________
if test `wc -l < parser-escape.scm` -ne 26; then
echo 'shar: parser-escape.scm was damaged during transit (should have been 26 lines)'
fi
fi ; : end of overwriting check
echo 'x - scoops.doc'
if test -f scoops.doc; then echo 'shar: not overwriting scoops.doc'; else
sed 's/^X//' << '________This_Is_The_END________' > scoops.doc
XFrom: sherin@linc.cis.upenn.edu
XDate: 17-JUN-1987 00:47
XSubj: Re: Scoops Request
X
XDefault values are set to #!false or '() instead of some unassigned
Xvalue. The reason is simple: if variables were actually unassigned
Xit would be necessary to check this out before looking up their
Xvalues. So the alternative was to use 'unassigned or such, and
XI thought why not just use the "standard" nonsense value.
X
X
XTo compile scoops, execute
X
X (sf "scoops.scm")
X
XAfterwards, just load in the binary with
X
X(load "scoops.bin")
X
XClasses are are defined in a global context!.
X
XFunctions:
X----------
X
XDEFINE-CLASS
X
X(define-class name <optional> (mixins <parent-classes>)
X (classvars <binding-pairs or names for default value>)
X (instvars " " " )
X (options <set-list> <get-list> <init-list>))
X
X<set-list> = settable-variables (all can be set!) |
X (settable-variables <var1 .. varn>)
X
X<get-list> analogous to <set-list>
X
X<init-list> analogous to the set-/get-lists except for initialization
X of (only instance) variables.
X
XMAKE-INSTANCE
X
X(make-instance name '<var1> <val1> ... '<varN> <valN>)
X
Xcreates an instance of class name with those variables bound
Xto those values provided they are inittable.
XUse a variable to bind the instance returned as it does not side-effect
Xthe environment.
X
XCOMPILE-CLASS
X
X(compile-class <class>) sets up the environments for classvars and methods.
XClasses could be auto-compiled upon generation, but the TI version
Xdoes not do this. If anyone really wants it set up that way, get in touch.
X
Xclass-of-object
X(class-of-object <obj>) simply returns the class-name of an object.
X
XNAME->CLASS
X
X(name->class '<name>) {Ex. (name->class 'klass) }
X
Xreturns the class structure of <name>.
X
XMETHODS
X
X(methods <class>)
Xreturns a list of methods available to that class and defined within
Xthat class.
X
Xall-methods
X(all-methods <class>)
Xcf methods--returns inherited methods as well.
X
Xclassvars
Xsimilar to methods.
X
Xall-classvars
Xsimilar to all-methods.
X
XINSTVARS
Xsimilar to classvars and methods.
X
XALL-INSTVARS
Xsimilar to all-classvars and all-methods.
X
XMIXINS
Xreturns all of the class's parents.
X
XRENAME-CLASS
X(rename-class (<old> <new>))
Xredefines <old> as <new>, replacing the internal name flags.
X
XGETCV
X(getcv <class> <class-var>)
Xreturns a gettable class-var.
X
XSETCV
X(setcv <class> <class-var> <val>)
Xsets a settable class-var to val.
X
XCLASS-COMPILED?
X(class-compiled? <class>) does what it ought to do.
X
XDESCRIBE
X(describe <instance-or-class>)
Xgives relevant information about either a class or an instance.
X
XSEND
X(send <instance> <message> <optional-arguments>)
Xevaluates <message> wrt the class and instance and whatever args
Xare required.
X
XSEND-IF-HANDLES
X(Same syntax as send.)
XSend-if-handles returns #!false if the method (message) is
Xinappropiate.
X
XDEFINE-METHOD
X(define-method (<class> <method-name>) <lambda-list> <body>))
Xdefines a function that has access to class and instance variables
X(HOW DOES IT KNOW WHICH INSTANCE? See send.scm for some fast
Xflying.) The method also has access to other methods (something
Xand ordinary function as an inst-var or class-var would not).
X
XDELETE-METHOD
X(delete-method (<class> <method-name>) )
Xdestroys a method.
X
X
XSHORT EX.
X=========
X
X
X(load "scoops.bin")
X(define-class thing (classvars (location 'here))
X;;Don't use where! It gets into the debugger in the new cscheme.
X(instvars (one 1) two (three (active 4 1+ 1+)))
X
X(options gettable-variables (settable-variables one) inittable-variables))
X
X
X;;variable attributes:
X;;
X;;
X;; name init- get- set-
X;;==================================================================
X;; location no yes no
X;;
X;; one yes yes yes
X;;
X;; two yes yes no
X;;
X;; three yes yes yes
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;NB If some variable is initialized, that value overrides
X;;any default from active instance variables or stated defaults
X;;(eg (thisvar 'this-val) ).
X;;
X;;Actives:
X;;
X;; by setting the initial value of an instance variable to
X;; (active <default> <get-enhancer> <set!-enhancer>)
X;;
X;; the variable gets init'ed to <default> (unless otherwise stated
X;; previously) and the "enhancers" are called each time the get-
X;; and set- methods are used. Actives automatically generate
X;; get- and set- methods (which override any declarations
X;; of settable/gettable variables at class definition time).
X;;
X;; NB The methods generated to access variables at startup time
X;; are called get-<thing> and set-<thing>.
X;;------------------------------------------------------------------
X
X
X
XI hope the above (short) documentation helps. Enjoy!!
XQuestions to me:
X
Xsherin@linc.cis.upenn.edu
X
X
________This_Is_The_END________
if test `wc -l < scoops.doc` -ne 182; then
echo 'shar: scoops.doc was damaged during transit (should have been 182 lines)'
fi
fi ; : end of overwriting check
exit 0
--
Mike Clarkson mike@ists.UUCP
Institute for Space and Terrestrial Science mike@ists.ists.ca
York University, North York, Ontario, uunet!mnetor!yunexus!ists!mike
CANADA M3J 1P3 +1 (416) 736-5611