;;; -*-Scheme-*-
;;; basics--split from toplevel for zelk, to provide error handling for
;;; elk shells.
;;; If elk is invoked without any -l files to load, it always loads
;;; the file toplevel, which in turn (requires) this file.  
;;; #! Elk invokes elk with the name of the script as the first arg.
;;; In this case, this file loads the first arg and resets the
;;; top level handler locally here, so that the (require 'basics) in
;;; top level never returns - the new local top level exits instead.
;;; Load -l does not produce any commandline arguments
;;; (Not sure if -l still works with this scheme.)
;;; modified zilla
;;; 17oct	update to 2.0
;;; 3mar	update to 1.5b
;;; 18feb	error handler prints hostname
;;; 13dec	load anything mentioned on commandline.  allows #! shells
;;; 4sep	fix "1+" bug (error-handler redefined w/o setting context)
;;; 28aug	load .elkrc into top-level-environment

;(display "loading basics")(newline)
(provide 'basics) ;&zelk

(autoload 'pp 'pp)
(autoload 'apropos 'apropos)
(autoload 'flame 'flame)
(autoload 'sort 'qsort)
(autoload 'define-structure 'struct)
(autoload 'describe 'describe)
(autoload 'backtrace 'debug)
(autoload 'inspect 'debug)

;; &zelk synonyms for naming consistency
(define os-chdir chdir)
(define os-read-directory read-directory)
(define os-file-status file-status)
(define os-file-exists? file-exists?)
(define os-bsh system)
(define os-csh csh)

;;&zelk
;;**************** define top-level reploop, but top-level
;;**************** is only called in the file toplevel.
;;**************** define it here so that it can be used as an error reploop

(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)
	);begin
    );if. returns () on eof
  );let
);rep-loop

(define rep-frames)
(define rep-level)

(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 top-level-environment (the-environment))

(define (top-level)
  (let loop ()
    ;(format #t "toplevel ")
    (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))
	; if lambda returns normally, #f is returned and loop is not called.
	; lambda will only return normally on eof.
	; control-point is called with #t by error/interrupt handlers,
	; in which case we start a new reploop.
	(loop)
    );if
  );let
);top-level

(define (the-top-level)
  (top-level)
  (newline)
  (exit))


(define simple-interrupt-handler
  (lambda ()
    (format #t "~%\7Interrupt!~%")
    (let ((next-frame (car rep-frames)))
      (next-frame #t))))		;throw to most recent continuation

;; backtrace and inspect on ^C.
(define debug-interrupt-handler
  (lambda ()
    (format #t "~%\7Interrupt!~%")
    (backtrace)				;&zilla
    (inspect)
    (newline)
    (pop-frame)
    (let ((next-frame (car rep-frames)))
      (next-frame #t))
  );lambda
);define


;; shell file can set debug-interrupt-handler if desired.
; problem if we are interrupted between now and the binding of
; rep-* below.  could fix this by setting interrupt-handler immediately
; after setting up rep-*.
(set! interrupt-handler simple-interrupt-handler)
;(set! interrupt-handler debug-interrupt-handler)

(define (error-print error-msg)
  (format #t "~s: " (car error-msg))
  (apply format `(#t ,@(cdr error-msg)))
  (newline))

; if an error occurs before rep-* are assigned below,
; push-frame fails because rep-level is unbound
(set! error-handler
  (lambda error-msg
    (format #t "ERROR........~a ~a~%" (os-hostname) (command-line-args))
    (error-print error-msg)
    (backtrace)				;&zilla
    (let loop ()
      (if (call-with-current-continuation
	   (lambda (control-point)
	     (push-frame control-point)
	     (rep-loop (the-environment))
	     #f))
	  ;; lambda will return #f on eof, in which case we fall out
	  ;; below the let, do pop-frame and invoke the next frame with #t.
	  ;; If the next frame is also an error, we are back here and
	  ;; go into this begin, which will in turn probably be exited with ^D
	  ;; The last frame will always be a toplevel frame.
	  (begin			;then
	    (pop-frame)
	    ;(format #t "errloop begin~%")
	    (loop)
	  );begin
      );if
    );let
    ;(format #t "error-handler past loop~%")
    (newline)
    (pop-frame)
    (let ((next-frame (car rep-frames)))
      (next-frame #t))
  );lambda
);set

;; &zelk
;; set up a context to load .elkrc.  load *after* provide basics.
;; If an error occurs, we want to escape past the loading to
;; avoid an infinite loop.
(call-with-current-continuation
  (lambda (control-point)
    (set! rep-frames (list control-point))
    (set! top-level-control-point control-point)
    (set! rep-level 0)
    (let ((ini (tilde-expand "~/.elkrc")))
      (if (file-exists? ini) (load ini top-level-environment)))
    #f))

;; if (command-line-args) we decide that we are running a #! shell script:
;; load THE FIRST file mentioned on the commandline:
;;  "elk -l file" does not result in any commandline arguments
;;  "junk.esh: #! /ac/res/cnc/zilla/Elk" results in Elk being run
;;   with junk.esh as its first argument.  
;; Although toplevel loaded basics (this file), we set up a
;; continuation here which will exit if the shell load ever returns,
;; so basics will never return to toplevel.
;;
(if (not (null? (command-line-args)))
    (begin
     (call-with-current-continuation
      (lambda (control-point)
	(set! rep-frames (list control-point))
	(set! top-level-control-point control-point)
	(set! rep-level 0)
	(let ((a (tilde-expand (car (command-line-args)))))
	  (format #t "! loading ~a~%" a)
	  (load a top-level-environment)))
     );call/cc
     (exit 0)
    );begin
)
