From 59f770b92ec52ca639edf19965a1e54c8bca86df Mon Sep 17 00:00:00 2001
From: Lassi Kortela <lassi@lassi.io>
Date: Tue, 14 Feb 2023 21:13:08 +0200
Subject: [PATCH] Drop elk directory

---
 INSTALL                |   6 --
 elk/README             |   4 -
 elk/scm/debug.scm      | 212 -----------------------------------------
 elk/scm/initscheme.scm |  81 ----------------
 elk/scm/pp.scm         | 117 -----------------------
 elk/scm/toplevel.scm   | 110 ---------------------
 6 files changed, 530 deletions(-)
 delete mode 100644 elk/README
 delete mode 100644 elk/scm/debug.scm
 delete mode 100644 elk/scm/initscheme.scm
 delete mode 100644 elk/scm/pp.scm
 delete mode 100644 elk/scm/toplevel.scm

diff --git a/INSTALL b/INSTALL
index 975f6b7..803d8c6 100644
--- a/INSTALL
+++ b/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
diff --git a/elk/README b/elk/README
deleted file mode 100644
index de1d852..0000000
--- a/elk/README
+++ /dev/null
@@ -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.
diff --git a/elk/scm/debug.scm b/elk/scm/debug.scm
deleted file mode 100644
index 157535c..0000000
--- a/elk/scm/debug.scm
+++ /dev/null
@@ -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)))))
diff --git a/elk/scm/initscheme.scm b/elk/scm/initscheme.scm
deleted file mode 100644
index 476de0f..0000000
--- a/elk/scm/initscheme.scm
+++ /dev/null
@@ -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))
diff --git a/elk/scm/pp.scm b/elk/scm/pp.scm
deleted file mode 100644
index 05d8e8a..0000000
--- a/elk/scm/pp.scm
+++ /dev/null
@@ -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)))))))
-
diff --git a/elk/scm/toplevel.scm b/elk/scm/toplevel.scm
deleted file mode 100644
index 55edd9f..0000000
--- a/elk/scm/toplevel.scm
+++ /dev/null
@@ -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)