;;; Miscellaneous.scheme
;;; Copyright Ó 1988, 1989, 1990, 1991 by Xerox Corporation. All rights reserved.
;;; Last changed by Pavel on April 2, 1990 3:35 pm PDT
;;; Michael Plass, April 3, 1989 1:51:39 pm PDT
;;; Booleans
(define (not x)
(if x #f #t))
(define nil #f)
(define t #t)
;;; Equivalence predicates
(define (vector-equal? x y start end)
(if (= start end)
#t
(and (equal? (vector-ref x start) (vector-ref y start))
(vector-equal? x y (+ start 1) end))))
(define (equal? x y)
(cond
((eqv? x y) #t)
((pair? x)
(and (pair? y)
(equal? (car x) (car y))
(equal? (cdr x) (cdr y))))
((vector? x)
(and (vector? y)
(= (vector-length x) (vector-length y))
(vector-equal? x y 0 (vector-length x))))
((string? x)
(and (string? y)
(string=? x y)))
;;; Strings
(define (string-append . strings)
"Append an arbitrary number of strings"
(cond
((null? (cdr strings))
(car strings))
(else
(apply string-append (essential-string-append (car strings)
(cadr strings))
(cddr strings)))))
(define (number->string x)
;; BOGUS IMPLEMENTATION!! But it works just fine for now.
(format #f "~S" x))
;;; Vectors
(define (vector . x)
"Create a vector containing the arguments"
(list->vector x))
(define (vector-fill! v obj)
"Fill vector v with obj"
(let ((len (vector-length v)))
(let loop ((i 0))
(when (< i len)
(vector-set! v i obj)
(loop (+ i 1))))))
(define (vector->list v)
(let ((result '()))
(let loop ((i (- (vector-length v) 1)))
(cond
(else
(set! result (cons (vector-ref v i) result))
(loop (- i 1)))))))
;;; Control features
(define (apply proc . args)
"(proc arg1 ... argn) Apply PROC to ARG1 ... ARG(n-1) and the elements of the list ARGn"
(cond
((null? args)
(error "Too few arguments to APPLY"))
((null? (cdr args))
(essential-apply proc (car args)))
(else
(let loop ((tail args)
(rest (cdr args)))
(cond
((null? (cdr rest))
(set-cdr! tail (car rest))
(essential-apply proc args))
(else
(loop (cdr tail) (cdr rest))))))))
(define (force promise)
(promise))
(define head car) ; for streams, as in Ableson & Sussman2
(define (tail foo)
"for streams, as in Ableson & Sussman2"
(force (cdr foo)))
(define empty-stream? null?)
(define the-empty-stream '())
;;; I/O
(define (call-with-input-file file-name proc)
(let* ((port (open-input-file file-name))
(result (proc port)))
(close-input-port port)
result))
(define (call-with-output-file file-name proc)
(let* ((port (open-output-file file-name))
(result (proc port)))
(close-output-port port)
result))
(define (with-input-from-file file-name thunk)
(let ((port (open-input-file file-name)))
(define (swap)
(define old (current-input-port))
(%set-current-input-port! port)
(set! port old))
(let ((result (dynamic-wind swap thunk swap)))
(close-input-port port)
result
)))
(define (with-output-to-file file-name thunk)
(let ((port (open-output-file file-name)))
(define (swap)
(define old (current-output-port))
(%set-current-output-port! port)
(set! port old))
(let ((result (dynamic-wind swap thunk swap)))
(close-output-port port)
result
)))
;;; Combinators
(define (compose . functions)
"Function composition"
(let loop ((fns functions))
(cond
((null? fns)
(lambda (x) x))
((null? (cdr fns))
(car fns))
(else
(let ((f (car fns))
(g (loop (cdr fns))))
(lambda x (f (apply g x))))))))
;;; Apropos
string-match? is implemented in Cedar now, by calling Rope.Match.
(define (string-match? pattern target)
"Does the pattern string (which may contain *s) match target string?"
(define pn (string-length pattern))
(define tn (string-length target))
(define (match-from pi ti)
(or
(and (= pi pn) (= ti tn))
(and
(< pi pn)
(< ti tn)
(or
(and
(eqv? (string-ref pattern pi) (string-ref target ti))
(match-from (+ 1 pi) (+ 1 ti))
)
(and
(eqv? (string-ref pattern pi) #\*)
(or
(= (+ 1 pi) pn)
(match-from (+ 1 pi) (+ 1 ti))
(match-from pi (+ 1 ti))
)
)
)
)
)
)
(match-from 0 0)
)
(define (apropos pattern . as-list?)
"find symbols in the environment that match pattern"
(define count 0)
(define result '())
(define collect
(if (equal? as-list? '(#t))
(lambda (sym) (set! result (cons sym result)))
(lambda (sym) (set! count (+ count 1)) (display sym) (newline))
)
)
(define (check sym val)
(if (string-ci-match? pattern sym) (collect sym))
)
(define (walk-env-chain fn env)
"apply fn to env and all its parents"
(when env
(fn env)
(walk-env-chain fn (environment-parent env))
)
)
(walk-env-chain (lambda (env) (walk-environment check env)) user)
(if (equal? as-list? '(#t)) (sort result string<? symbol->string) count)
)
;;; Read-Eval-Print and Load notes
(define *load-notes* '())
(define (*load-note-taker* file-description defined-symbols)
(set! *load-notes*
(cons (list file-description defined-symbols) *load-notes*)))
(define *read-eval-print-notes* '())
(define (read-eval-print-notes)
(reverse *read-eval-print-notes*))
(define & #f)
(define (*read-eval-print-note-taker* form exp . rest)
(when (pair? rest)
(set! & (car rest)))
(set! *read-eval-print-notes* (cons form *read-eval-print-notes*)))
;;; Viewers
(define (eval-selection)
(let ((p (open-input-string (get-selection-contents))))
(let loop ((form (read p))
(results '()))
(cond
((eof-object? form)
(reverse! results))
(else
(loop (read p) (cons (eval form user) results)))))))
(define *default-context* #f)
(define event-kind car)
(define (event-x event)
(case (event-kind event)
((buttondown buttonup mouseto erased)
(cadr event))
(else
(error 'event-x event "Event has no x-coordinate"))))
(define (event-y event)
(case (event-kind event)
((buttondown buttonup mouseto erased)
(caddr event))
(else
(error 'event-y event "Event has no y-coordinate"))))
(define (event-button event)
(case (event-kind event)
((buttondown buttonup)
(cadddr event))
(else
(error 'event-button event "Event has no mouse button"))))
(define (event-shift event)
(case (event-kind event)
((buttondown buttonup)
(car (cddddr event)))
((mouseto)
(cadddr event))
(else
(error 'event-shift event "Event has no ctrlshift parameter"))))
;;; Environment manipulation
(define (walk-environment fn env)
(for-each (lambda (pair)
(fn (car pair) (cdr pair)))
(%environment->alist env)))
;;; Code-as-data tools
(define (eval expr env)
(apply (*system-compiler* (*system-syntax-expander* expr env) env) '()))
(define (kwote v)
(if (or (number? v)
(string? v)
(boolean? v)
(char? v))
v
`(quote ,v)))