;;; swank-scheme48.scm --- Scheme48 backend for SLIME.
;;;
;;; Written by Helmut Eller, 2004.  
;;;
;;; Some code is copy&pasted from the Scheme48 sources.  Should work
;;; with Scheme 48 0.57.
;;;

(define-structure swank-macros (export unwind-protect)
  (open scheme)
  (begin
    (define-syntax unwind-protect 
      (syntax-rules ()
	((unwind-protect work undo ...)
	 (dynamic-wind (lambda () #f) (lambda () work)
		       (lambda () undo ...)))))
    ))

(define-structure swank (export start-swank)
  ;; Hmm... is there a "open-all-except" command?
  (open scheme swank-macros environments evaluation 
	(subset package-commands-internal (config-package))
	util sockets big-scheme fluids handle 
	conditions display-conditions 
	exceptions continuations 
	disclosers debug-data debug-data-internal debuginfo vm-exposure
	packages packages-internal
	escapes i/o posix
	list-interfaces interfaces
	primitives closures locations cells records record-types low-level
	defpackage ensures-loaded
	syntactic weak
	enumerated interrupts signals threads threads-internal)
  ;; (open menus (prefix menus::))
  (begin "
(" ;; <- force "wrong" indentation

(define nil #f)
(define t #t)
(define (1+ n) (+ n 1))
;; (define (1- n) (- n 1)) ; "1-" is invalid number syntax
(define (-1+ n) (- n 1))

(define (mappend fun list)
  (apply append (map fun list)))

(define (log-event fstring . args)
  ;;(apply format #t fstring args)
  #f
  )

(define swank-env (interaction-environment))

(define (swank port)
  (accept-connections port #f))

(define (start-swank port-file)
  (accept-connections #f port-file))

(define (accept-connections port port-file)
  (let ((socket (if port (open-socket port) (open-socket))))
    (format #t "Waiting on port ~D ~%" (socket-port-number socket))
    (if port-file (write-port-file (socket-port-number socket) port-file))
    (unwind-protect (receive (in out) (socket-accept socket) 
		      (serve-requests in out))
      (format #t "Closing socket... ~A~%" socket)
      (close-socket socket))))

(define (write-port-file portnumber filename)
  (call-with-output-file filename (lambda (p) (write portnumber p))))

;; Naming conventions for fluids is: *NAME*
(define *socket-in* (make-fluid #f))
(define *socket-out* (make-fluid #f))

;; Poor mans restarts: alist of name . continuation
(define *restarts* (make-fluid '())) 
(define call/cc call-with-current-continuation)
(define (with-restart name body)
  (call/cc (lambda (k)
	     (let-fluids *restarts* (cons (cons name k) (fluid *restarts*))
			 body))))

;;; Simple single threaded version  (interrupting doesn't work)
(define (serve-requests in out)
  (let-fluids *socket-out* out
	      *socket-in* in
	      (lambda () 
		(let loop () 
		  (with-restart 'serve-requests 
		    (lambda () (read-from-emacs)))
		  (loop)))))

(define (read-from-emacs)
  (let ((msg (read-request (fluid *socket-in*))))
    (log-event "READ: ~S~%" msg)
    (dispatch msg)))
 
(define (read-request in)
  "Read an S-expression from STREAM using the SLIME protocol."
  (let* ((len (read-length in))
	 (buffer (make-string len)))
    (fill-buffer! in buffer)
    (read-from-string buffer)))

(define (fill-buffer! in buffer)
  "Fill the string BUFFER with chars read from input port IN."
  (read-block buffer 0 (string-length buffer) in))

(define (read-length in)
  (let loop ((pos 6) (sum 0))
    (if (zero? pos) 
	sum
	(loop (-1+ pos) 
	      (+ (* sum 16) (char->hex-digit (read-char in)))))))

(define (ldb size position integer)
  "LoaD a Byte of SIZE bits at bit position POSITION from INTEGER."
  (bitwise-and (arithmetic-shift integer (- position))
	       (-1+ (arithmetic-shift 1 size))))

(define (send-to-emacs message)
  (let* ((string (prin1-to-string message))
	 (out (fluid *socket-out*)))
    (log-event "WRITE: [~D]~S~%" (string-length string) string)
    (write-length (string-length string) out)
    (write-string string out)
    (force-output out)))

(define (write-length len out)
  (do ((pos 20 (- pos 4)))
      ((< pos 0))
    (write-hex-digit (ldb 4 pos len) out)))

(define (write-hex-digit n out)
  (write-char (hex-digit->char n) out))

(define (hex-digit->char n)
  (if (< n 10)
      (ascii->char (+ (char->ascii #\0) n))
      (ascii->char (+ (char->ascii #\a) n -10))))

(define (char->hex-digit c)
  (let ((code (char->ascii c))  (a-code (char->ascii #\a)))
    (if (< code a-code)
	(- code (char->ascii #\0))
	(+ 10 (- code a-code)))))

(define (dispatch message)
  (case (car message)
    ((:emacs-rex)
     (destructure (((form package thread id) (cdr message)))
       (eval-for-emacs form package id)))))

(define (eval-for-emacs form package id)
  (with-handler debugger-hook
    (lambda ()
      (let ((ok? #f) (result #f))
	(unwind-protect
	    (begin (set! result (eval form swank-env))
		   (set! ok? #t))
	  (send-to-emacs `(:return ,(if ok? `(:ok ,result) 
					'(:abort))
				   ,id)))))))

(define *sldb-level* (make-fluid 0))
(define *sldb-restarts* (make-fluid #f))
(define *sldb-cont* (make-fluid #f))
;; (fluid *sldb-cont*)
(define (cons* car . rest)
  (if (null? rest) 
      car
      (cons car (apply cons* rest))))

(define (debugger-hook condition decline)
  (let ((level (1+ (fluid *sldb-level*))))
    (let-fluids *sldb-cont* (primitive-cwcc (lambda (k) k))
		*sldb-level* level
		*sldb-restarts* (fluid *restarts*)
		(lambda ()
		  (unwind-protect
		      (begin 
			(send-to-emacs 
			 `(:debug 0 ,level 
				  ,@(debugger-info-for-emacs condition 0 20)))
			(debug-loop level))
		    (send-to-emacs `(:debug-return 0 ,level)))))))

(define (debug-loop level)
  (with-restart (intern (format #f "return-to-sldb-level-~D" level))
    (lambda () 
      (send-to-emacs `(:debug-activate 0 ,level))
      (read-from-emacs)))
  (debug-loop level))

(define (format-restarts)
  (map (lambda (s) (list (symbol->string s) ""))
       (map car (fluid *restarts*))))

(define (debugger-info-for-emacs condition start end)
  (list (list (format-condition condition)
	      (format #f "  [~A]" (condition-type condition))
	      'nil
	      'nil)
	(format-restarts)
	(backtrace (fluid *sldb-cont*) start end)
	'()))

(define (format-condition condition)
  (trim-whitespace (with-output-to-string 
		       (lambda (p)
			 (display-condition condition p)))))

(define (swank:invoke-nth-restart-for-emacs level n)
  ((cdr (list-ref (fluid *sldb-restarts*) n)) #f))

(define (last-car list)
  (cond ((null? list) #f)
	((null? (cdr list)) (car list))
	(else (last-car (cdr list)))))

(define (swank:throw-to-toplevel)
  (let ((restart (last-car (fluid *restarts*))))
    (if restart
	((cdr restart)))))

(define (swank:connection-info) 
  (list (getpid) "Scheme 48" "scheme48" '() 'nil))

(define (getpid) (process-id->integer (get-process-id)))

(define (swank:listener-eval string) (swank:interactive-eval string))

(define (swank:interactive-eval string)
  (call-with-values
      (lambda () 
	(let ((exp (read-from-string string)))
	  (if (eof-object? exp)
	      (values)
	      (eval exp swank-env))))
    format-for-echo-area))

(define (format-for-echo-area . values)
  (if (null? values) 
      "; No value"
      (with-output-to-string
	  (lambda (out)
	    (do ((vs values (cdr vs))) ((null? vs))
	      (write (car vs) out)
	      (if (not (null? (cdr vs)))
		  (write-string ", " out)))))))

(define (swank:buffer-first-change filename) 'nil)
(define (swank:arglist-for-echo-area names) 'nil)

(define (with-output-to-string fn)
  "Call FN with a string output port and return the output as string."
  (let ((p (make-string-output-port)))
    (fn p)
    (string-output-port-output p)))

(define (read-from-string string) (read (make-string-input-port string)))

(define (prin1-to-string o) (with-output-to-string (lambda (p) (write o p))))
(define (princ-to-string o) (with-output-to-string (lambda (p) (display o p))))

(define intern string->symbol)

(define (whitespace? char) (memq (char->ascii char) ascii-whitespaces))

(define (trim-whitespace string)
  (let* ((len (string-length string))
	 (stop? (lambda (i) (not (whitespace? (string-ref string i)))))
	 (start (do ((i 0 (1+ i))) 
		    ((or (= i len) (stop? i))
		     i)))
	 (end (do ((i len (-1+ i)))
		  ((or (= i start) (stop? (-1+ i)))
		   i))))
    (substring string start end)))

;; There doesn't seem to be some central repository for packages,
;; interfaces, or structures.  Instead structures are simple stored in
;; normal variables.  Scary.
(define (%get-structure name)
  (environment-ref (config-package) name))

(define (: structure-name name)
  "Find the binding for NAME in the package named PACKAGE-NAME.
Example: (: 'pp 'p)"
  (*structure-ref (get-package package-name) name))

(define (:: structure-name name)
  (let* ((pack (structure-package (%get-structure structure-name))))
    (ensure-loaded (%get-structure structure-name))
    (location-for-reference pack name)))

(define (package package-designator)
  (let ((pd package-designator))
    (cond ((package? pd) pd)
	  ((symbol? pd) 
	   (package (environment-ref (config-package) pd)))
	  ((structure? pd)
	   (structure-package pd))
	  (t (error "No package for" pd)))))

(define (clients x)
  (population->list (cond ((package? x) (package-clients x))
			  ((structure? x) (structure-clients x))
			  ((interface? x) (interface-clients x))
			  (t (error "bug" x)))))

(define (uses x)
  (cond ((package? x) (package-opens x))
	((structure? x) (list (structure-package x)
			      (structure-interface x)))
	((interface? x) '())
	(t (error "bug" x))))

(define (module-thingy? x)
  (or (structure? x)
      (package? x)
      (interface? x)))

(define (collect-module-things package)
  (let loop ((accu '()) (worklist (list package)))
    (if (null? worklist) 
	accu
	(let ((p (car worklist)))
	  (if (memq p accu)
	      (loop accu (cdr worklist))
	      (loop (cons p accu)
		    (append (clients p)
			    (uses p)
			    (if (package? p) 
				(filter-package module-thingy? p)
				'())
			    (cdr worklist))))))))

(define (filter-package test package)
  (let ((accu '()))
    (table-walk (lambda (key val)
		  (if (not (syntax? (vector-ref val 2)))
		      (let ((v (environment-ref package key)))
			(if (test v)
			    (set! accu (cons v accu))))))
		(package-definitions package))
    accu))

(define (prefix? prefix string start)
  (let ((len (string-length prefix)))
    (if (< (string-length string) len)
	#f
	(let loop ((i 0))
	  (cond ((= i len) #t)
		((char=? (string-ref prefix i)
			 (string-ref string (+ i start)))
		 (loop (1+ i)))
		(t #f))))))

(define (match? pattern string)
  (let ((max (- (string-length string) (string-length pattern))))
    (let loop ((i 0))
      (cond ((< max i) #f)
	    ((prefix? pattern string i) #t)
	    (t (loop (1+ i)))))))

(define (apropos-list pattern)
  (let ((packages (filter package? (collect-module-things (config-package))))
	(accu '()))
    (for-each (lambda (p)
		(table-walk (lambda (key val)
			      (if (and (symbol? key)
				       (match? pattern (symbol->string key)))
				  (set! accu (cons (cons key val) accu))))
			    (package-definitions p)))
	      packages)
    accu))

(define (swank:apropos-list-for-emacs name . x)
  (map (lambda (x) (destructure (((name . def) x))
		     (list ':designator (prin1-to-string name)
			   ':variable (princ-to-string def))))
       (apropos-list name)))

(define (swank:simple-completions prefix . package) '())
  
(define (swank:backtrace from to)
  (backtrace (fluid *sldb-cont*) from to))

(define (backtrace cont from to)
  (let* ((preview (continuation-preview cont))
	 ;;(bt (remove-dynbind-frames preview))
	 (bt (safe-sublist preview from to)))
    (let rep ((i from) (bt bt))
      (if (null? bt) 
	  '()
	  (cons (list i (frame-for-emacs i (car bt)))
		(rep (1+ i) (cdr bt)))))))

(define (remove-dynbind-frames preview)
  (filter (lambda (x) (not (fluid-let-continuation-info? (car x))))
	  preview))

(define (safe-sublist list from to)
  (let outer ((l list) (i 0))
    (cond ((null? l) 
	   '())
	  ((= i from)
	   (let inner ((l l) (i i))
	     (cond ((or (<= to i) (null? l))
		    '())
		   (else 
		    (cons (car l) (inner (cdr l) (1+ i)))))))
	  (else 
	   (outer (cdr l) (1+ i))))))

(define (frame-for-emacs n frame)
  (let ((info+pc frame))
    (trim-whitespace
     (with-output-to-string 
	 (lambda (port)
	   (display-template-names (car info+pc) port))))))
  
;; ripped of from debug.scm 
;;(define (preview)
;;  (let ((cont (command-continuation)))
;;    (if cont
;;	  (display-preview (continuation-preview cont)
;;			   (command-output)))))

(define (display-preview preview port)
  (for-each (lambda (info+pc)
	      (if (not (fluid-let-continuation-info? (car info+pc)))
		  (display-template-names (car info+pc) port)))
	    preview))

(define (display-template-names info port)
  (let ((names (debug-data-names info)))
    (display "  " port)
    (if (null? names)
	(begin (display "unnamed " port)
	       (write `(id ,(if (debug-data? info)
				(debug-data-uid info)
				info))
		      port))
	(let loop ((names names))
	  (if (car names)
	      (write (car names) port)
	      (display "unnamed" port))
	  (if (and (not (null? (cdr names)))
		   (cadr names))
	      (begin (display " in " port)
		     (loop (cdr names))))))
    (newline port)))

(define fluid-let-continuation-info?	;Incestuous!
  (let ((id (let-fluid (make-fluid #f) #f
	      (lambda ()
		(primitive-catch (lambda (k)
				   (template-id
				    (continuation-template k))))))))
    (lambda (info) 
      (eqv? (if (debug-data? info)
		(debug-data-uid info)
		info)
	    id))))

(define (nth-frame n)
  (do ((c (fluid *sldb-cont*) (continuation-parent c))
       (n n (- n 1)))
      ((zero? n) c)))

(define (swank:frame-locals-for-emacs n)
  (map (lambda (x) (destructure (((label value) x))
		     (list ':name (princ-to-string label)
			   ':value (prin1-to-string value)
			   ':id 0)))
       (prepare-continuation-menu (nth-frame n))))

(define (swank:frame-catch-tags-for-emacs . x)
  'nil)

(define (continuation-debug-data thing)
  (template-debug-data (continuation-template thing)))

;;; Inspector

(define inspectee #f)
(define inspectee-parts #f)
(define inspector-stack '())
(define inspector-history '())
(define inspector-history-index 0)
(define inspect-length 30)

(define (reset-inspector)
  (set! inspectee #f)
  (set! inspectee-parts '())
  (set! inspector-stack '())
  (set! inspector-history '()))

(define (swank:init-inspector string)
   (reset-inspector)
   (inspect-object (eval (read-from-string string) swank-env)))

(define (inspector-nth-part index)
  (list-ref inspectee-parts index))
 
(define (swank:inspect-nth-part index)
  (inspect-object (inspector-nth-part index)))
 
(define (swank:inspector-pop)
  (cond ((pair? (cdr inspector-stack))
	 (let ((o (cadr inspector-stack)))
	   (set! inspector-stack (cddr inspector-stack))
	   (inspect-object o)))
	(t 'nil)))
 
(define (swank:inspector-next)
  (let ((pos (position inspectee inspector-history)))
    (cond ((= pos (- (length inspector-history) 1))
	   'nil)
	  (t (inspect-object (list-ref inspector-history (1+ pos)))))))

(define (swank:quit-inspector)
  (reset-inspector)
  'nil)

(define (print-part-to-string value)
  (let ((string (prin1-to-string value))
	(pos (position value inspector-history)))
    (if pos
	(format #f "#~D=~A" pos string)
	string)))

(define (inspect-object o)
  (set! inspectee o)
  (set! inspector-stack (cons o inspector-stack))
  (let ((pos (position o inspector-history)))
    (if (not pos)
	(set! inspector-history (append inspector-history (list o)))))
  (receive (text type parts) (inspected-parts o)
    (set! inspectee-parts parts)
    (list ':title (format #f "~A ~A" (print-part-to-string o) text)
	  ':type type
	  ':content (mappend contents-for-part parts))))

(define (contents-for-part part)
  (destructure (((label value) part))
    `(,(princ-to-string label)
      ": " (:value ,(print-part-to-string value) ,(assign-index value))
      ,(string #\newline))))

(define (assign-index value)
  (or (position value inspectee-parts)
      (let ((len (length inspectee-parts)))
	(set! inspectee-parts (append inspectee-parts (list value)))
	len)))
  
(define (indexed-parts thing length ref)
  (do ((i (- length 1)  (- i 1))
       (a '() (cons (list i (ref thing i)) a)))
      ((= -1 i) a)))

;; A lot of stuff below is copied from menu.scm.

(define (inspected-parts thing)
  (cond ((vector? thing)
	 (values "is a vector" "vector"
		 (indexed-parts thing (vector-length thing) vector-ref)))
	((template? thing)
	 (values "is a template" "template"
		 (indexed-parts thing (template-length thing) template-ref)))
	((pair? thing)
	 (let ((length (careful-length thing)))
	   (if (eq? length 'improper)
	       (values "is a pair (or improper list)" "cons"
		       `((car ,(car thing))
			 (cdr ,(cdr thing))))
	       (values "is a list" "cons"
		       (indexed-parts thing length list-ref)))))
	((closure? thing)
	 (values "is a closure" "closure" 
		 (prepare-environment-menu
		  (closure-env thing)
		  (debug-data-env-shape (template-debug-data
					 (closure-template thing))
					0))))
	((continuation? thing)
	 (values "is a closure" "closure" 
		 (prepare-continuation-menu thing)))
	((record? thing)
	 (values "is a record" "record" 
		 (prepare-record-menu thing)))
	((location? thing)
	 (values "is a location" "location" 
		 `((id ,(location-id thing))
		   (contents ,(contents thing)))))
	((cell? thing)
	 (values "is a cell" "cell" 
		 `((ref ,(cell-ref thing)))))
	((weak-pointer? thing)
	 (values "weak-pointer" "weak-pointer" 
		 `((ref ,(weak-pointer-ref thing)))))
	(t (values "dunno" "???" `()))))

(define (careful-length list)
  (let loop ((fast list) (len 0) (slow list) (move-slow? #f))
    (cond ((eq? '() fast)
	   len)
	  ((not (pair? fast))
	   'improper)
	  ((not move-slow?)
	   (loop (cdr fast) (+ len 1) slow #t))
	  ((eq? fast slow)
	   'circular)
	  (else
	   (loop (cdr fast) (+ len 1) (cdr slow) #f)))))

(define (prepare-environment-menu env shape)
  (if (vector? env)
      (let ((values (rib-values env)))
        (if (pair? shape)
            (append (map list (car shape) values)
                    (prepare-environment-menu (vector-ref env 0)
                                              (cdr shape)))
            (append (map (lambda (x)
			   (list #f x))
			 values)
                    (prepare-environment-menu (vector-ref env 0)
					      shape))))
      '()))

(define (rib-values env)
  (let ((z (vector-length env)))
    (do ((i 1 (+ i 1))
	 (l '() (cons (if (vector-unassigned? env i)
			  'unassigned
			  (vector-ref env i))
		      l)))
	((>= i z) l))))

(define (prepare-record-menu thing)
  (let ((rt (record-type thing))
        (z (record-length thing)))
    (if (record-type? rt)
        (do ((i (- z 1) (- i 1))
             (f (reverse (record-type-field-names rt)) (cdr f))
             (l '() (cons (list (car f) (record-ref thing i)) l)))
            ((< i 1) l))
        (do ((i (- z 1) (- i 1))
             (l '() (cons (list #f (record-ref thing i)) l)))
            ((< i 0) l)))))

(define (prepare-continuation-menu thing)
  (let ((next (continuation-parent thing)))
    `(,@(let recur ((c thing))
	  (if (eq? c next)
	      '()
	      (let ((z (continuation-arg-count c)))
		(do ((i (- z 1) (- i 1))
		     (l (recur (continuation-cont c))
			(cons (list #f (continuation-arg c i))
			      l)))
		    ((< i 0) l)))))
      ,@(prepare-environment-menu
	  (continuation-env thing)
	  (debug-data-env-shape (continuation-debug-data thing)
				(continuation-pc thing))))))))

;; Local Variables:
;; eval: (put 'unwind-protect 'scheme-indent-function 1)
;; eval: (put 'receive 'scheme-indent-function 2)
;; eval: (put 'destructure 'scheme-indent-function 1)
;; End: