Drop elk directory

Lassi Kortela 4 months ago
parent d8bfced2b7
commit 59f770b92e

@ -42,12 +42,6 @@ o Go to the sub-directory "src" below the directory where you unpacked
o Call "make depend" and then "make".
o You may want to remove the minimal Elk runtime environment contained
in the directory "elk" and replace it by a symbolic link to your
site's Elk runtime directory (i.e. the directory with sub-directories
"scm" and "obj").
o Test unroff and the HTML back-end included in the distribution.
For example, change to the directory "doc" and run "make" to convert

@ -1,4 +0,0 @@
This directory holds a minimal, self-contained Elk runtime environment.
All the files have been copied from the Elk 3.0 distribution. If you
have Elk installed at your site, you can replace this directory by
a symbolic link to your site's Elk runtime directory.

@ -1,212 +0,0 @@
;;; -*-Scheme-*-
;;; A simple debugger (improvements by Thomas M. Breuel <tmb@ai.mit.edu>).
(define (backtrace . args)
(if (> (length args) 1)
(error 'backtrace "too many arguments"))
(if (not (null? args))
(if (not (eq? (type (car args)) 'control-point))
(error 'backtrace "argument must be a control point")))
(let ((trace (apply backtrace-list args)))
(if (null? args)
(set! trace (cdddr trace)))
(show-backtrace trace 0 999999)))
(define (show-backtrace trace start-frame end-frame)
(define (rjust n x)
(let* ((y (string-append (make-string n #\space) x))
(l (string-length y)))
(substring y (- l n) l)))
(let ((maxlen 28))
(let loop ((frames (list-tail trace start-frame)) (num start-frame))
(if (or (null? frames) (>= num end-frame)) #v
(let ((frame (car frames)))
(let* ((func
(format #f "~s" (vector-ref frame 0)))
(- maxlen (+ 5 (string-length func)))))
(display (rjust 4 (number->string num)))
(display " ")
(display func)
(if (negative? indent)
(set! indent maxlen)))
(do ((i indent (1- i)))
((> 0 i))
(display " ")))
((print-depth 2)
(print-length 3))
(display (vector-ref frame 1)))
(loop (cdr frames) (1+ num))))))
(define (show-environment env)
((print-length 2)
(print-depth 2))
(do ((f (environment->list env) (cdr f)))
((null? f))
(do ((b (car f) (cdr b)))
((null? b))
(format #t "~s\t~s~%" (caar b) (cdar b)))
(print '-------)))
(define inspect)
(let ((frame)
'("q -- quit inspector"
"f -- print current frame"
"u -- go up one frame"
"d -- go down one frame"
"^ -- go to top frame"
"$ -- go to bottom frame"
"g <n> -- goto to n-th frame"
"e -- eval expressions in environment"
"p -- pretty-print procedure"
"v -- show environment"
"<n> -- pretty-print n-th argument"
"b -- show backtrace starting at current frame"
"t -- show top of bracktrace starting at current frame"
"z -- show and move top of backtrace starting at current frame"
"o -- obarray information")))
(define (inspect-command-loop)
(let ((input) (done #f))
(display "inspect> ")
(set! input (read))
(case input
(set! done #t))
(lambda (msg)
(display msg)
(set! frame 0)
(set! frame (1- (length trace)))
(if (zero? frame)
(format #t "Already on top frame.~%")
(set! frame (1- frame))
(if (= frame (1- (length trace)))
(format #t "Already on bottom frame.~%")
(set! frame (1+ frame))
(set! input (read))
(if (integer? input)
(set! frame
(cond ((negative? input) 0)
((>= input (length trace)) (1- (length trace)))
(else input)))
(format #t "Frame number must be an integer.~%")))
(show-environment (vector-ref (list-ref trace frame) 2)))
(format #t "Type ^D to return to Inspector.~%")
(let loop ()
(display "eval> ")
(set! input (read))
(if (not (eof-object? input))
(write (eval input
(vector-ref (list-ref trace frame) 2)))
(pp (vector-ref (list-ref trace frame) 0))
(show-backtrace trace frame (+ frame 10))
(set! frame (+ frame 9))
(if (>= frame (length trace)) (set! frame (1- (length trace)))))
(show-backtrace trace frame (+ frame 10)))
(show-backtrace trace frame 999999))
(let ((l (map length (oblist))))
(let ((n 0))
(for-each (lambda (x) (set! n (+ x n))) l)
(format #t "~s symbols " n)
(format #t "(maximum bucket: ~s).~%" (apply max l)))))
((integer? input)
(let ((args (vector-ref (list-ref trace frame) 1)))
(if (or (< input 1) (> input (length args)))
(format #t "No such argument.~%")
(pp (list-ref args (1- input)))
((eof-object? input)
(set! done #t))
(format #t "Invalid command. Type ? for help.~%")))))
(if (not done)
(define (print-frame)
(format #t "~%Frame ~s of ~s:~%~%" frame (1- (length trace)))
(let* ((f (list-ref trace frame)) (args (vector-ref f 1)))
(format #t "Procedure: ~s~%" (vector-ref f 0))
(format #t "Environment: ~s~%" (vector-ref f 2))
(if (null? args)
(format #t "No arguments.~%")
((print-depth 2)
(print-length 3))
(do ((i 1 (1+ i)) (args args (cdr args))) ((null? args))
(format #t "Argument ~s: ~s~%" i (car args))))))
(define (find-frame proc)
(let loop ((l trace) (i 0))
(cond ((null? l) -1)
((eq? (vector-ref (car l) 0) proc) i)
(else (loop (cdr l) (1+ i))))))
(set! inspect
(lambda ()
(set! trace (backtrace-list))
(set! trace (cddr trace))
(do ((t trace (cdr t)) (f 1 (1+ f))) ((null? t))
(if (not (null? (vector-ref (car t) 1)))
(let ((last (last-pair (vector-ref (car t) 1))))
(if (not (null? (cdr last)))
(format #t
"[inspector: fixing improper arglist in frame ~s]~%" f)
(set-cdr! last (cons (cdr last) '())))))))
(set! frame (find-frame error-handler))
(if (negative? frame)
(set! frame 0))
(format #t "Inspector (type ? for help):~%")
(let loop ()
(if (call-with-current-continuation
(lambda (control-point)
(push-frame control-point)
(let ((next-frame (car rep-frames)))
(next-frame #t)))))

@ -1,81 +0,0 @@
;;; -*-Scheme-*-
;;; Initialization code for the Elk interpreter kernel.
;;; This file is loaded on startup before the toplevel (or the file
;;; supplied along with the -l option) is loaded.
;;; If a garbage collection is triggered while loading this file,
;;; it is regarded as an indication that the heap size is too small
;;; and an error message is printed.
;;; Primitives that are part of the core functionality but are not
;;; implemented in C. This is a bad thing, because extension or
;;; application writers should be able to rely on P_Expt().
(define (expt x y)
(define (square x) (* x x))
(define (integer-expt b n)
(cond ((= n 0) 1)
((negative? n) (/ 1 (integer-expt b (abs n))))
((even? n) (square (integer-expt b (/ n 2))))
(else (* b (integer-expt b (- n 1))))))
(cond ((zero? x) (if (zero? y) 1 0))
((integer? y) (integer-expt x y))
(else (exp (* (log x) y)))))
;;; Synonyms:
(define call/cc call-with-current-continuation)
;;; Backwards compatibility. These procedures are really obsolete;
;;; please do not use them any longer.
(define (close-port p)
(if (input-port? p) (close-input-port p) (close-output-port p)))
(define (void? x) (eq? x (string->symbol "")))
(define (re-entrant-continuations?) #t)
;;; Useful macros (these were loaded by the standard toplevel in
;;; earlier versions of Elk). They shouldn't really be here, but
;;; it's too late...
(define (expand form)
(if (or (not (pair? form)) (null? form))
(let ((head (expand (car form))) (args (expand (cdr form))) (result))
(if (and (symbol? head) (bound? head))
(set! result (macro-expand (cons head args)))
(if (not (equal? result form))
(expand result)
(cons head args)))))
(define-macro (unwind-protect body . unwind-forms)
(lambda () #f)
(lambda () ,body)
(lambda () ,@unwind-forms)))
(define-macro (while test . body)
`(let loop ()
(cond (,test ,@body (loop)))))
(define-macro (when test . body)
`(cond (,test ,@body)))
(define-macro (unless test . body)
`(when (not ,test) ,@body))
(define-macro (multiple-value-bind vars form . body)
`(apply (lambda ,vars ,@body) ,form))

@ -1,117 +0,0 @@
;;; -*-Scheme-*-
;;; Trivial pretty-printer
(provide 'pp)
(define pp)
(let ((max-pos 55) (pos 0) (tab-stop 8))
(put 'lambda 'special #t)
(put 'macro 'special #t)
(put 'define 'special #t)
(put 'define-macro 'special #t)
(put 'define-structure 'special #t)
(put 'fluid-let 'special #t)
(put 'let 'special #t)
(put 'let* 'special #t)
(put 'letrec 'special #t)
(put 'case 'special #t)
(put 'call-with-current-continuation 'long #t)
(put 'quote 'abbr "'")
(put 'quasiquote 'abbr "`")
(put 'unquote 'abbr ",")
(put 'unquote-splicing 'abbr ",@")
(set! pp (lambda (x)
(set! pos 0)
(cond ((eq? (type x) 'compound)
(set! x (procedure-lambda x)))
((eq? (type x) 'macro)
(set! x (macro-body x))))
(fluid-let ((garbage-collect-notify? #f))
(pp-object x))
(define (flat-size s)
(fluid-let ((print-length 50) (print-depth 10))
(string-length (format #f "~a" s))))
(define (pp-object x)
(if (or (null? x) (pair? x))
(pp-list x)
(if (void? x)
(display "#v")
(write x))
(set! pos (+ pos (flat-size x)))))
(define (pp-list x)
(if (and (pair? x)
(symbol? (car x))
(string? (get (car x) 'abbr))
(= 2 (length x)))
(let ((abbr (get (car x) 'abbr)))
(display abbr)
(set! pos (+ pos (flat-size abbr)))
(pp-object (cadr x)))
(if (> (flat-size x) (- max-pos pos))
(pp-list-vertically x)
(pp-list-horizontally x))))
(define (pp-list-vertically x)
(maybe-pp-list-vertically #t x))
(define (pp-list-horizontally x)
(maybe-pp-list-vertically #f x))
(define (maybe-pp-list-vertically vertical? list)
(display "(")
(set! pos (1+ pos))
(if (null? list)
(display ")")
(set! pos (1+ pos)))
(let ((pos1 pos))
(pp-object (car list))
(if (and vertical?
(and (pair? (car list))
(not (null? (cdr list))))
(and (symbol? (car list))
(get (car list) 'long))))
(indent-newline (1- pos1)))
(let ((pos2 (1+ pos)) (key (car list)))
(let tail ((flag #f) (l (cdr list)))
(cond ((pair? l)
(if flag
(if (and (symbol? key) (get key 'special))
(1+ pos1)
(display " ")
(set! pos (1+ pos)))
(pp-object (car l))
(tail vertical? (cdr l)))
(cond ((not (null? l))
(display " . ")
(set! pos (+ pos 3))
(if flag (indent-newline pos2))
(pp-object l)))
(display ")")
(set! pos (1+ pos)))))))))
(define (indent-newline x)
(set! pos x)
(let loop ((i x))
(cond ((>= i tab-stop)
(display "\t")
(loop (- i tab-stop)))
((> i 0)
(display " ")
(loop (1- i)))))))

@ -1,110 +0,0 @@
;;; -*-Scheme-*-
;;; Read-eval-print loop and error handler
(autoload 'pp 'pp.scm)
(autoload 'apropos 'apropos.scm)
(autoload 'sort 'qsort.scm)
(autoload 'describe 'describe.scm)
(autoload 'backtrace 'debug.scm)
(autoload 'inspect 'debug.scm)
(define ?)
(define ??)
(define ???)
(define !)
(define !!)
(define !!!)
(define &)
(define (rep-loop env)
(define input)
(define value)
(let loop ()
(set! ??? ??)
(set! ?? ?)
(set! ? &)
;;; X Windows hack
(if (and (bound? 'display-flush-output) (bound? 'dpy) (display? dpy))
(display-flush-output dpy))
(if (> rep-level 0)
(display rep-level))
(display "> ")
(set! input (read))
(set! & input)
(if (not (eof-object? input))
(set! value (eval input env))
(set! !!! !!)
(set! !! !)
(set! ! value)
(write value)
(define rep-frames)
(define rep-level)
(set! interrupt-handler
(lambda ()
(format #t "~%\7Interrupt!~%")
(let ((next-frame (car rep-frames)))
(next-frame #t))))
(define-macro (push-frame control-point)
(set! rep-frames (cons ,control-point rep-frames))
(set! rep-level (1+ rep-level))))
(define-macro (pop-frame)
(set! rep-frames (cdr rep-frames))
(set! rep-level (1- rep-level))))
(define (error-print error-msg)
(format #t "~s: " (car error-msg))
(apply format `(#t ,@(cdr error-msg)))
(set! error-handler
(lambda error-msg
(error-print error-msg)
(let loop ((intr-level (enable-interrupts)))
(if (positive? intr-level)
(loop (enable-interrupts))))
(let loop ()
(if (call-with-current-continuation
(lambda (control-point)
(push-frame control-point)
(rep-loop (the-environment))
(let ((next-frame (car rep-frames)))
(next-frame #t))))
(define top-level-environment (the-environment))
(define (top-level)
(let loop ()
;;; Allow GC to free old rep-frames when we get here on "reset":
(set! rep-frames (list top-level-control-point))
(if (call-with-current-continuation
(lambda (control-point)
(set! rep-frames (list control-point))
(set! top-level-control-point control-point)
(set! rep-level 0)
(rep-loop top-level-environment)
(define (the-top-level)