Drop elk directory
This commit is contained in:
parent
d8bfced2b7
commit
59f770b92e
6
INSTALL
6
INSTALL
|
|
@ -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)))
|
||||
(indent
|
||||
(- maxlen (+ 5 (string-length func)))))
|
||||
(display (rjust 4 (number->string num)))
|
||||
(display " ")
|
||||
(display func)
|
||||
(if (negative? indent)
|
||||
(begin
|
||||
(newline)
|
||||
(set! indent maxlen)))
|
||||
(do ((i indent (1- i)))
|
||||
((> 0 i))
|
||||
(display " ")))
|
||||
(fluid-let
|
||||
((print-depth 2)
|
||||
(print-length 3))
|
||||
(display (vector-ref frame 1)))
|
||||
(newline))
|
||||
(loop (cdr frames) (1+ num))))))
|
||||
|
||||
(define (show-environment env)
|
||||
(fluid-let
|
||||
((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 '-------)))
|
||||
#v)
|
||||
|
||||
(define inspect)
|
||||
|
||||
(let ((frame)
|
||||
(trace)
|
||||
(help-text
|
||||
'("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
|
||||
(q
|
||||
(set! done #t))
|
||||
(?
|
||||
(for-each
|
||||
(lambda (msg)
|
||||
(display msg)
|
||||
(newline))
|
||||
help-text))
|
||||
(f
|
||||
(print-frame))
|
||||
(^
|
||||
(set! frame 0)
|
||||
(print-frame))
|
||||
($
|
||||
(set! frame (1- (length trace)))
|
||||
(print-frame))
|
||||
(u
|
||||
(if (zero? frame)
|
||||
(format #t "Already on top frame.~%")
|
||||
(set! frame (1- frame))
|
||||
(print-frame)))
|
||||
(d
|
||||
(if (= frame (1- (length trace)))
|
||||
(format #t "Already on bottom frame.~%")
|
||||
(set! frame (1+ frame))
|
||||
(print-frame)))
|
||||
(g
|
||||
(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.~%")))
|
||||
(v
|
||||
(show-environment (vector-ref (list-ref trace frame) 2)))
|
||||
(e
|
||||
(format #t "Type ^D to return to Inspector.~%")
|
||||
(let loop ()
|
||||
(display "eval> ")
|
||||
(set! input (read))
|
||||
(if (not (eof-object? input))
|
||||
(begin
|
||||
(write (eval input
|
||||
(vector-ref (list-ref trace frame) 2)))
|
||||
(newline)
|
||||
(loop))))
|
||||
(newline))
|
||||
(p
|
||||
(pp (vector-ref (list-ref trace frame) 0))
|
||||
(newline))
|
||||
(z
|
||||
(show-backtrace trace frame (+ frame 10))
|
||||
(set! frame (+ frame 9))
|
||||
(if (>= frame (length trace)) (set! frame (1- (length trace)))))
|
||||
(t
|
||||
(show-backtrace trace frame (+ frame 10)))
|
||||
(b
|
||||
(show-backtrace trace frame 999999))
|
||||
(o
|
||||
(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)))))
|
||||
(else
|
||||
(cond
|
||||
((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)))
|
||||
(newline))))
|
||||
((eof-object? input)
|
||||
(set! done #t))
|
||||
(else
|
||||
(format #t "Invalid command. Type ? for help.~%")))))
|
||||
(if (not done)
|
||||
(inspect-command-loop))))
|
||||
|
||||
(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.~%")
|
||||
(fluid-let
|
||||
((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))))))
|
||||
(newline))
|
||||
|
||||
(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)))
|
||||
(begin
|
||||
(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)
|
||||
(inspect-command-loop)
|
||||
#f))
|
||||
(begin
|
||||
(pop-frame)
|
||||
(loop))))
|
||||
(newline)
|
||||
(pop-frame)
|
||||
(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))
|
||||
form
|
||||
(let ((head (expand (car form))) (args (expand (cdr form))) (result))
|
||||
(if (and (symbol? head) (bound? head))
|
||||
(begin
|
||||
(set! result (macro-expand (cons head args)))
|
||||
(if (not (equal? result form))
|
||||
(expand result)
|
||||
result))
|
||||
(cons head args)))))
|
||||
|
||||
(define-macro (unwind-protect body . unwind-forms)
|
||||
`(dynamic-wind
|
||||
(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))
|
||||
117
elk/scm/pp.scm
117
elk/scm/pp.scm
|
|
@ -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))
|
||||
#v))
|
||||
|
||||
(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)
|
||||
(begin
|
||||
(display ")")
|
||||
(set! pos (1+ pos)))
|
||||
(let ((pos1 pos))
|
||||
(pp-object (car list))
|
||||
(if (and vertical?
|
||||
(or
|
||||
(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
|
||||
(indent-newline
|
||||
(if (and (symbol? key) (get key 'special))
|
||||
(1+ pos1)
|
||||
pos2))
|
||||
(display " ")
|
||||
(set! pos (1+ pos)))
|
||||
(pp-object (car l))
|
||||
(tail vertical? (cdr l)))
|
||||
(else
|
||||
(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)
|
||||
(newline)
|
||||
(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))
|
||||
(begin
|
||||
(set! value (eval input env))
|
||||
(set! !!! !!)
|
||||
(set! !! !)
|
||||
(set! ! value)
|
||||
(write value)
|
||||
(newline)
|
||||
(loop)))))
|
||||
|
||||
(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)
|
||||
`(begin
|
||||
(set! rep-frames (cons ,control-point rep-frames))
|
||||
(set! rep-level (1+ rep-level))))
|
||||
|
||||
(define-macro (pop-frame)
|
||||
'(begin
|
||||
(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)))
|
||||
(newline))
|
||||
|
||||
(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))
|
||||
#f))
|
||||
(begin
|
||||
(pop-frame)
|
||||
(loop))))
|
||||
(newline)
|
||||
(pop-frame)
|
||||
(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)
|
||||
#f))
|
||||
(loop))))
|
||||
|
||||
(define (the-top-level)
|
||||
(top-level)
|
||||
(newline)
|
||||
(exit))
|
||||
|
||||
(the-top-level)
|
||||
Loading…
Reference in New Issue