;;; -*- Mode:LISP; Package:LAMBDA; Base:8 -*-

;use this if you have put a breakpoint at trans-really-trap 
(defun (:property fix-unbound-variable lam-colon-cmd) (val &aux md)
  (prog ()
	(cond ((not (equal (lam-find-closest-sym (+ (lam-register-examine rapc) racmo))
			   '(trans-really-trap 1)))
	       (format t "~&You are not stopped at (TRANS-REALLY-TRAP 1)")
	       (return))
	      ((not (= (lam-register-examine rausp) 3))
	       (format t "~&USP is not equal to 3")
	       (return))
	      ((not (equal (lam-find-closest-sym (+ (lam-register-examine (+ rauso 2)) racmo))
			   '(fetch-fef-offset 3)))
	       (format t "~&2@us is does not contain (FETCH-FEF-OFFSET 3)")
	       (return))
	      ((not (= (qf-data-type (lam-register-examine ramd)) dtp-null))
	       (format t "~&the MD does not contain DTP-NULL")
	       (return)))
	
	(setq md (lam-register-examine ramd))
	(format t "~&MD now contains ")
	(lam-q-print-toplev md)
	(cond ((null val)
	       (let ((sym-name-as-string (qf-fetch-string (qf-p-contents md)))
		     (pkg-name-as-string (qf-fetch-string
					   (qf-pkg-name (qf-p-contents (+ md 4))))))
		 (format t "~&The symbol is ~a in package ~a"
			 sym-name-as-string
			 pkg-name-as-string)
		 (cond ((null (pkg-find-package pkg-name-as-string ':find))
			(format t "~&No package ~s on this machine" pkg-name-as-string)
			(return))
		       (t
			(let ((sym (intern sym-name-as-string pkg-name-as-string)))
			  (cond ((not (boundp sym))
				 (format t "~&The symbols ~s is not bound on this machine"
					 sym)
				 (let ((sym2 (intern sym-name-as-string "LAMBDA")))
				   (cond ((boundp sym2)
					  (format t "~&But is does have a value in LAMBDA")
					  (cond ((fquery nil "Use it? ")
						 (setq sym sym2))
						(t
						 (return))))))))
			  (cond ((not (fixnump (symeval sym)))
				 (format t "~&The value of ~s is ~s ... too complicated"
					 sym (symeval sym))
				 (return)))
			  (setq val (symeval sym))))))))
	
	(setq val (qf-make-q val dtp-fix (qf-cdr-code md)))
	(format t "   Going to change it to ~o" val)
	(cond ((fquery nil "Ok? ")
	       (lam-register-deposit rausp 1)
	       (lam-go (lam-lookup-name 'fetch-fef-offset))
	       (lam-register-deposit ramd val)
	       (qf-p-store-contents (1+ md) val)
	       ))))

(defstruct macro-breakpoint
  macro-breakpoint-function
  macro-breakpoint-lc
  macro-breakpoint-instruction
  macro-breakpoint-installed-now
  )

(defvar macro-breakpoint-list)
(defvar halt-macro-inst)

(defun (:property :macro-b lam-colon-cmd) (func &aux lc)
  (prog done ()
	(setq halt-macro-inst				;this is a reasonable approximation
	      (dpb (or (get '%halt 'compiler:qlval)
		       (get 'si:%halt 'compiler:qlval))
		   0011
		   115000))
	(if (null func)
	    (setq func lam-last-value-typed))
	(format t "~&Function: ")
	(lam-q-print-toplev func)
	(format t "~&What LC? ")
	(setq lc (read))
	;;someday check to make sure LC is reasonable
	(remove-macro-breakpoint func lc)
	(let ((mb (make-macro-breakpoint)))
	  (setf (macro-breakpoint-function mb) func)
	  (setf (macro-breakpoint-lc mb) lc)
	  (setf (macro-breakpoint-installed-now mb) nil)
	  (install-macro-breakpoint mb))))

(defun install-macro-breakpoint (mb)
  (set-single-step-macro-inst-mode)
  (cond ((macro-breakpoint-installed-now mb)
	 (ferror nil "trying to smash in a breakpoint that is already installed")))
  (let* ((func (macro-breakpoint-function mb))
	 (lc (macro-breakpoint-lc mb))
	 (inst-adr (+ func (truncate lc 2)))
	 (byte-spec (if (ldb-test 0001 lc) 2020 0020))
	 (old-word (lam-register-examine inst-adr)))
    (setf (macro-breakpoint-instruction mb) (ldb byte-spec old-word))
    (lam-register-deposit inst-adr (dpb halt-macro-inst byte-spec old-word))
    (setf (macro-breakpoint-installed-now mb) t))
  (push mb macro-breakpoint-list))

(defun assure-all-macro-breakpoints-intalled ()
  (dolist (mb macro-breakpoint-list)
    (cond ((null (macro-breakpoint-installed-now mb))
	   (install-macro-breakpoint mb)))))

(defun find-macro-breakpoint (func lc)
  (dolist (mb macro-breakpoint-list)
    (cond ((and (= (macro-breakpoint-function mb) func)
		(= (macro-breakpoint-lc mb) lc))
	   (return mb)))))

(defun remove-macro-breakpoint (func lc &optional (forever t) &aux got-one)
  (let ((inst-adr (+ func (truncate lc 2)))
	(byte-spec (if (ldb-test 0001 lc) 2020 0020))
	(mb (find-macro-breakpoint func lc)))
    (cond ((and (null mb) (null forever))
	   (ferror nil "couldn't find breakpoint to temporarily remove"))
	  ((null mb))
	  ((null (macro-breakpoint-installed-now mb))
	   (if forever
	       (setq macro-breakpoint-list (delq mb macro-breakpoint-list))))
	  (t
	   (let ((current-word (lam-register-examine inst-adr)))
	     (cond ((= (ldb byte-spec current-word) halt-macro-inst)
		    (lam-register-deposit inst-adr
					  (dpb (macro-breakpoint-instruction mb)
					       byte-spec
					       current-word))
		    (if forever
			(setq macro-breakpoint-list (delq mb macro-breakpoint-list))
		      (setf (macro-breakpoint-installed-now mb) nil)))
		   (t
		    (format t "~&Macro breakpoint at ")
		    (lam-q-print-toplev (macro-breakpoint-function mb))
		    (format t " LC = ~o " (macro-breakpoint-lc mb))
		    (format t "clobbered")
		    (setq macro-breakpoint-list (delq mb macro-breakpoint-list)))))))))

(defun (:property :macro-ub lam-colon-cmd) (func &aux lc)
  (if (null func)
      (setq func lam-last-value-typed))
  (format t "~&Function: ")
  (lam-q-print-toplev func)
  (format t "~&What LC? ")
  (setq lc (read))
  (cond ((null (remove-macro-breakpoint func lc))
	 (format t "~&No breakpoint found there"))))

(defun (:property :macro-listb lam-colon-cmd) (ignore)
  (dolist (mb macro-breakpoint-list)
    (format t "~&")
    (lam-q-print-toplev (macro-breakpoint-function mb))
    (format t " LC=~o" (macro-breakpoint-instruction mb))))

(defun (:property :macro-hit-breakpoint lam-colon-cmd) (ignore)
  (lam-macro-hit-breakpoint))

(defun lam-macro-hit-breakpoint ()
  (prog done
	((func (lam-register-examine (+ rapbo (lam-symbolic-examine-register 'm-ap))))
	 lc mb)
	(cond ((not (= (ldb %%qf-data-type func) dtp-fef-pointer))
	       (format t "~&M-AP doesn't seem to be pointing to a function")
	       (return)))
	(setq lc (qf-pointer (ash (- (lam-symbolic-examine-register 'lc) 2) -1)))
	(setq mb (find-macro-breakpoint func lc))
	(cond ((null mb)
	       (format t "~&You don't seem to be stopped at any known breakpoint")
	       (return)))
	(remove-macro-breakpoint mb lc nil)
	(lam-symbolic-deposit-register 'lc lc)	;a side effect of writing the LC is
						;that it forces the MACRO-IR to be
						;reloaded
	(setq lam-saved-ir 20000002507)		;(popj)
	(setq lam-noop-flag nil)
	(setq lam-update-display-flag t)
	)


;----------------
#|

(defvar macro-breakpoint-function)
(defvar macro-breakpoint-lc)
(defvar macro-breakpoint-old-instruction)
(defvar macro-breakpoint-instruction-location)

(defun executed-macro-breakpoint ()
  (lam-register-deposit macro-breakpoint-instruction-location 
			macro-breakpoint-old-instruction)
  (setq lam-saved-micro-stack-ptr 0)
  (setq lam-saved-ir 20000002507)		;(popj)
  (lam-write-lc (- (lam-read-lc) 2))
  (lam-register-deposit rastep 1)		;step the machine once to get back to 
  (setq lam-update-display-flag t)		;macro instruction loop
  (setq lam-open-register nil))

(DEFUN (:PROPERTY macro-ubreak lam-colon-cmd) (ignore)
  "Unset a macro breakpoint"
  (executed-macro-breakpoint))

(DEFUN (:PROPERTY macro-restore lam-colon-cmd) (ignore)
  (lam-register-deposit macro-breakpoint-instruction-location
			macro-breakpoint-old-instruction)
  (format t "~&Done.~&"))

(DEFUN (:PROPERTY macro-break lam-colon-cmd) (ignore)
  "Set a macro breakpoint"
  (setq macro-breakpoint-function lam-last-value-typed)
  (format t "~%Function ")
  (lam-q-print macro-breakpoint-function lam-sexp-prinlevel)
  (format t " What LC ? ")
  (setq macro-breakpoint-lc (read))
  (setq macro-breakpoint-instruction-location (+ macro-breakpoint-function
						 (// macro-breakpoint-lc 2)))
  (setq macro-breakpoint-old-instruction
	(lam-register-examine macro-breakpoint-instruction-location))
  (lam-register-deposit macro-breakpoint-instruction-location
			(if (zerop (logand 1 macro-breakpoint-lc))
			    (dpb 15673 0020 macro-breakpoint-old-instruction)
			  (dpb 15673 2020 macro-breakpoint-old-instruction)))
  (format t "~&Done.~&"))

|#