;;; -*- Mode:LISP; Package:USER; Readtable:ZL; Base:10 -*- (defvar *FALCON-DEBUGGER-FRAME* nil "The frame of the FALCON debugger") (defflavor call-stack-flavor ((stack-info nil)) (tv:function-text-scroll-window tv:mouse-sensitive-text-scroll-window tv:text-scroll-window tv:borders-mixin tv:top-label-mixin tv:basic-scroll-bar tv:flashy-scrolling-mixin tv:margin-scroll-mixin tv:margin-region-mixin tv:margin-choice-mixin tv:scroll-stuff-on-off-mixin tv:dont-select-with-mouse-mixin tv:pane-mixin tv:window) (:default-init-plist :label '(:string "Call Stack Dump" :centered :font fonts:metsi) :blinker-p nil :deexposed-typeout-action ':permit :save-bits t :flashy-scrolling-region '((20 0.30 0.70) (20 0.30 0.70)) :margin-scroll-regions '((:top) (:bottom)) :scroll-bar-always-displayed t :font-map (list fonts:cptfont fonts:cptfontb fonts:tr12 fonts:tr10 fonts:tr10b fonts:tr12b) :print-function 'output-line) :settable-instance-variables :inittable-instance-variables :gettable-instance-variables) (defflavor frame-pane-flavor () (tv:function-text-scroll-window tv:mouse-sensitive-text-scroll-window tv:text-scroll-window tv:borders-mixin tv:top-label-mixin tv:basic-scroll-bar ; tv:flashy-scrolling-mixin ; tv:margin-scroll-mixin ; tv:margin-region-mixin ; tv:margin-choice-mixin tv:scroll-stuff-on-off-mixin tv:dont-select-with-mouse-mixin tv:pane-mixin tv:process-mixin tv:window) (:default-init-plist :label '(:string "Call Stack Dump" :centered :font fonts:metsi) :blinker-p nil :deexposed-typeout-action ':permit :save-bits t :process '(display-process) ; :flashy-scrolling-region '((20 0.30 0.70) (20 0.30 0.70)) ; :margin-scroll-regions '((:top) (:bottom)) ; :scroll-bar-always-displayed t :font-map (list fonts:cptfont fonts:cptfontb fonts:tr12 fonts:tr10 fonts:tr10b fonts:tr12b) :print-function 'output-line-frame) :settable-instance-variables :inittable-instance-variables :gettable-instance-variables) (defmethod (call-stack-flavor :adjustable-size-p) () nil) (defmethod (call-stack-flavor :enable-scrolling-p) () tv:scroll-bar-always-displayed) (defun output-line (text arg window &rest ignore) arg (if (cdr text) (progn (funcall window :add-line-info text) (format window " ") (funcall window :item1 (car text) :call-stack #'princ)) (format window "~A" (car text)) ) ) (defmethod (frame-pane-flavor :adjustable-size-p) () nil) (defmethod (frame-pane-flavor :enable-scrolling-p) () tv:scroll-bar-always-displayed) (defmethod (call-stack-flavor :add-line-info) (line) (setq stack-info (nconc stack-info `(,line))) ) (defun output-line-frame (item arg window &rest ignore) arg (case (car item) (:header (format window "Left ~:[ ~;*~]~8,'0x Right ~:[ ~;*~]~8,'0x Opn #x~2,'0x, Act #x~2,'0x, Rtn #x~2,'0x" (second item) (third item) (fourth item) (fifth item) (sixth item) (seventh item) (eighth item))) (:header-from-call-stack-entry (format window " Ret-Dest ~:[ O~; A~; R~; G~;NO~;NO~;NT~;NT~]~2,'0D Open ~2,'0X Active ~2,'0X rpc ~6,'0X" (second item) (third item) (fourth item) (fifth item) (sixth item)) ) (:blank-line (format window " ")) (:register (let ((reg (second item))) ;; when boxed make it mouse sensitive, otherwise non since it is not a lisp object. (format window " ") (if (third item) ;; boxed open reg (funcall-self :item1 (format nil "O~2D~:[ ~;*~]~8,'0x" reg (third item) (fourth item)) :register #'princ) (format window "O~2D~:[ ~;*~]~8,'0x" reg (third item) (fourth item))) (format window " ") (if (fifth item) ;; boxed Active reg (funcall-self :item1 (format nil "A~2D~:[ ~;*~]~8,'0x" reg (fifth item) (sixth item)) :register #'princ) (format window "A~2D~:[ ~;*~]~8,'0x" reg (fifth item) (sixth item))) (format window " ") (if (seventh item) ;; boxed Return reg (funcall-self :item1 (format nil "R~2D~:[ ~;*~]~8,'0x" reg (seventh item) (eighth item)) :register #'princ) (format window "R~2D~:[ ~;*~]~8,'0x" reg (seventh item) (eighth item))) ) ) (:register-from-call-stack-entry (let ((reg (second item))) ;; when boxed make it mouse sensitive, otherwise non since it is not a lisp object. (format window " ") (if (third item) ;; boxed open reg (funcall-self :item1 (format nil "O~2D~:[ ~;*~]~8,'0x" reg (third item) (fourth item)) :register #'princ) (format window "O~2D~:[ ~;*~]~8,'0x" reg (third item) (fourth item))) (format window " ") (if (fifth item) ;; boxed Active reg (funcall-self :item1 (format nil "A~2D~:[ ~;*~]~8,'0x" reg (fifth item) (sixth item)) :register #'princ) (format window "A~2D~:[ ~;*~]~8,'0x" reg (fifth item) (sixth item))) (format window " ") (format window "R~2D XXXXXXXX" reg (seventh item) (eighth item))) ) (otherwise nil) ) ) (defflavor kbug2-pane () (tv:interaction-pane tv:process-mixin) (:default-init-plist :blinker-deselected-visibility :on :blinker-flavor 'tv:rectangular-blinker :blinker-p t :deexposed-typein-action :normal :deexposed-typeout-action :normal :label "KBUG2" :Save-bits t :process '(kbug2-process)) :gettable-instance-variables :settable-instance-variables :inittable-instance-variables) (defun kbug2-process (&rest ignore) (let* ((*terminal-io* (send *FALCON-DEbugger-frame* :get-pane 'DEBUG-PANE))) (k-kbug:kbug2))) (defflavor wimp-pane () (tv:interaction-pane tv:process-mixin) (:default-init-plist :blinker-deselected-visibility :on :blinker-flavor 'tv:rectangular-blinker :blinker-p t :deexposed-typein-action :normal :deexposed-typeout-action :normal :label "WIMP" :save-bits t :process '(wimp-process)) :gettable-instance-variables :settable-instance-variables :inittable-instance-variables) (defun wimp-process (&rest ignore) (let* ((*terminal-io* (send *FALCON-DEbugger-frame* :get-pane 'WIMP-TERMINAL))) (k-kbug:wimp t))) (defun clean-up () (k-kbug:kbug2-flush-call-stack) (wind-show-call-stack) (wind-show-user-frame) ) (defun show-machine-state () (wind-show-call-stack) (wind-show-user-frame)) (defun stop-falcon () ) (defvar *listener-running* '( ("Flush Call Stack" :eval (clean-up) :font fonts:tr12bi :documentation "Clears the Call Stack Hardware") ("Show Call Stack" :eval (show-machine-state) :font fonts:tr12bi :documentation "Show Call Stack") ("Cold Boot Falcon" :eval (k-kbug:mega-boot) :font fonts:tr12bi :documentation "Builds a cold load and load the processor") ("Warm Boot Falcon" :eval (k-kbug:mega-boot t) :font fonts:tr12bi :documentation "Reloads the Falcon Processor") ("Run Debugger" :eval (stop-falcon) :font fonts:tr12bi :documentation "Runs the Read Eval Print loop of the Falcon") )) (defvar *Debugger-running* '( ("Flush Call Stack" :eval (clean-up) :font fonts:tr12bi :documentation "Clears the Call Stack Hardware") ("Show Call Stack" :eval (show-machine-state) :font fonts:tr12bi :documentation "Show Call Stack") ("Cold Boot Falcon" :eval (k-kbug:mega-boot) :font fonts:tr12bi :documentation "Builds a cold load and load the processor") ("Warm Boot Falcon" :eval (k-kbug:mega-boot t) :font fonts:tr12bi :documentation "Reloads the Falcon Processor") ("Run Listener" :eval (Run-listener) :font fonts:tr12bi :documentation "Runs the Read Eval Print loop of the Falcon") ("Run REP" :eval (Run-Rep) :font fonts:tr12bi :documentation "Runs the Read Eval Print loop of the Falcon") )) (defun Run-rep () (send (send *FALCON-DEbugger-frame* :get-pane 'WIMP-TERMINAL) :select) (send (send *falcon-debugger-frame* :get-pane 'command-pane) :set-item-list *listener-running*) (k-kbug:kbug2-run-rep) ) (k-kbug:define-k-function-invoker wind-kbug2-run-listener li::listener (format t "~&Warning! Running mini-lisp-listener smashes LI:ERROR on the K.") (unless (tv:menu-choose '(("Run it" :eval T :font fonts:tr12bi :documentation "Confirm it")) '(:string "Are you sure you want to run it?" :font fonts:tr12bi :centered)) (send (send *FALCON-DEbugger-frame* :get-pane 'debug-pane) :select) (send (send *falcon-debugger-frame* :get-pane 'menu-pane) :set-item-list *debugger-running*) (return-from wind-kbug2-run-listener NIL)) (format t "~&Running mini-lisp-listener on the K...")) (defun Run-listener () (send (send *FALCON-DEbugger-frame* :get-pane 'WIMP-TERMINAL) :select) (send (send *falcon-debugger-frame* :get-pane 'menu-pane) :set-item-list *listener-running*) (wind-kbug2-run-listener) ) (defun Run-debugger () ) (DEFFLAVOR FALCON-DEBUGGER-FRAME () (TV:BORDERED-CONSTRAINT-FRAME tv:top-box-label-mixin) (:DEFAULT-INIT-PLIST :LABEL '(:string "FALCON DEBUGGER" :font fonts:metsi :top :centered) :PANES `((DEBUG-PANE KBUG2-PANE :deexposed-typeout-action :permit :LABEL (:string "Falcon Debugger" :font ,fonts:tr12bi :top :centered) :SAVE-BITS T) (MENU-PANE TV:COMMAND-MENU :LABEL NIL :REVERSE-VIDEO-p T :SAVE-BITS T :ITEM-LIST ,*debugger-running* ) (CALL-STACK-PANE call-stack-flavor :LABEL (:string "Call Stack" :font ,fonts:tr12bi :centered :top) :SAVE-BITS t) (FRAME-PANE frame-pane-flavor :BLINKER-P NIL :font-map (,fonts:cptfont) :more-p nil :LABEL (:string "Current Stack Frame" :font ,fonts:tr12bi :centered :top) :SAVE-BITS T) (WIMP-TERMINAL WIMP-PANE :BLINKER-P T :deexposed-typeout-action :permit :LABEL (:string "Falcon Read Eval Print Process" :font ,fonts:tr12bi :centered :top) :SAVE-BITS T)) :CONSTRAINTS '((MAIN-CONF (MENU-PANE DUMMY-NAME21 WIMP-TERMINAL DEBUG-PANE) ((MENU-PANE 2 :LINES) (DUMMY-NAME21 :HORIZONTAL (17 :LINES frame-pane) (FRAME-PANE CALL-STACK-PANE) ((FRAME-PANE 60 :CHARACTERS)) ((CALL-STACK-PANE :EVEN))) (WIMP-TERMINAL 10 :LINES)) ((DEBUG-PANE :EVEN))) (DEBUGGER (MENU-PANE DUMMY-NAME19 DEBUG-PANE) ((MENU-PANE 1 :LINES) (DUMMY-NAME19 :HORIZONTAL (0.325035s0) (FRAME-PANE CALL-STACK-PANE) ((FRAME-PANE 60 :CHARACTERS)) ((CALL-STACK-PANE :EVEN)))) ((DEBUG-PANE :EVEN))) )) :GETTABLE-INSTANCE-VARIABLES :SETTABLE-INSTANCE-VARIABLES :INITTABLE-INSTANCE-VARIABLES) (defmethod (call-stack-flavor :flush-contents) (&optional (index 0)) (funcall-self :clear-screen) (store-array-leader 0 tv:items 0) (setq tv:top-item 0) ; (do () ; ((= (array-leader tv:items 0) index) ; t) ; (funcall-self :delete-item index)) (setq stack-info nil) ) (defmethod (frame-pane-flavor :flush-contents) (&optional (index 0)) (funcall-self :clear-screen) (store-array-leader 0 tv:items 0) (setq tv:top-item 0) ; (do () ; ((= (array-leader tv:items 0) index) ; t) ; (funcall-self :delete-item index)) ) (defmethod (frame-pane-flavor :show-user-frame) () (funcall-self :flush-contents) (k-kbug:kbug-cmd-confirm k2:kbug-command-read-call-stack) (let* ((user-open-frame (ldb (byte 8. 8.) (k-kbug:kbug-data (+ 2 (* 2 k-kbug:depth-to-user-OA-frame))))) (user-active-frame (ldb (byte 8. 0.) (k-kbug:kbug-data (+ 2 (* 2 k-kbug:depth-to-user-OA-frame))))) (user-return-frame (ldb (byte 8. 0.) (k-kbug:kbug-data (+ 2 (* 2 k-kbug:depth-to-user-R-frame))))) (o-list (k-kbug:read-frame-as-list user-open-frame)) (a-list (k-kbug:read-frame-as-list user-active-frame)) (r-list (k-kbug:read-frame-as-list user-return-frame)) (left (k-kbug:kbug-left)) (right (k-kbug:kbug-right)) (left-boxed (k-kbug:kbug-left-boxed)) (right-boxed (k-kbug:kbug-right-boxed))) (funcall-self :append-item `(:header ,(ldb-test (byte 1 0) left-boxed) ,left ,(ldb-test (byte 1 0) right-boxed) ,right ,user-open-frame ,user-active-frame ,user-return-frame) ) (funcall-self :append-item `(:blank-line)) (do* ((reg 0 (1+ reg)) (o o-list (cdr o)) (a a-list (cdr a)) (r r-list (cdr r))) ((= reg 16.)) (funcall-self :append-item `(:register ,reg ,(caar o) ,(cdar o) ,(caar a) ,(cdar a) ,(caar r) ,(cdar r))))) ) (defmethod (frame-pane-flavor :show-user-frame-from-call-stack-entry) (entry) (funcall-self :flush-contents) (let* ((user-open-frame (fourth entry)) (user-active-frame (fifth entry)) (o-list (k-kbug:kbug-generic-read-frame-as-list user-open-frame)) (a-list (k-kbug:kbug-generic-read-frame-as-list user-active-frame)) (rpc (first entry)) (rdf (second entry)) (rdr (third entry))) (funcall-self :append-item `(:header-from-call-stack-entry ,rdf ,rdr ,user-open-frame ,user-active-frame ,rpc)) (funcall-self :append-item `(:blank-line)) (do* ((reg 0 (1+ reg)) (o o-list (cdr o)) (a a-list (cdr a)) ) ((= reg 16.)) (funcall-self :append-item `(:register-from-call-stack-entry ,reg ,(caar o) ,(cdar o) ,(caar a) ,(cdar a))))) ) (defmethod (call-stack-flavor :show-call-stack) () (funcall-self :flush-contents) (funcall-self :append-item `(,(format nil "CALL Stack, Maching is ~:[running~;halted~]" (k-kbug:k-halted-p)) . nil)) (let ((cs (k-kbug:kbug-generic-read-call-stack-as-list))) (dolist (cse cs) (let* ((d0 (car cse)) (d1 (cadr cse)) (rpc (ldb (byte 24. 0.) d0)) (rdf (ldb (byte 3. 28.) d0)) (rdr (ldb (byte 4. 24.) d0)) (o (ldb (byte 8. 8.) d1)) (a (ldb (byte 8. 0.) d1)) (sym-adr (k-kbug:kbug-symbolic-address rpc))) (funcall-self :append-item `(,sym-adr . (,rpc ,rdf ,rdr ,o ,a))) ) ) ) ) (defun wind-show-call-stack () (send (send *falcon-debugger-frame* :get-pane 'call-stack-pane) :show-call-stack) ) (defvar *frame-stream* t) (defvar *call-stack-stream* t) (defvar *command-menu* nil) (DEFMETHOD (FALCON-DEBUGGER-FRAME :AFTER :INIT) (&REST IGNORE) (let ((io-buffer-1 (tv:make-io-buffer 1000.))) (send (funcall-self :get-pane 'menu-pane) :set-io-buffer io-buffer-1) (send (funcall-self :get-pane 'call-stack-pane) :set-io-buffer io-buffer-1) (send (funcall-self :get-pane 'frame-pane) :set-io-buffer io-buffer-1)) (FUNCALL-SELF :SET-SELECTION-SUBSTITUTE (FUNCALL-SELF :GET-PANE 'DEBUG-PANE))) (defmethod (FALCON-DEBUGGER-FRAME :selectable-windows) () (list (list tv:name self))) (defmethod (FALCON-DEBUGGER-FRAME :before :kill) (&rest ignore) (setq *FALCON-DEbugger-frame* nil)) (defun wbug (&optional (select-p t) starting-address) (when (or (not (boundp '*FALCON-DEbugger-frame*)) (null *FALCON-DEbugger-frame*) (not (typep *FALCON-DEbugger-frame* 'FALCON-DEbugger-frame)) (member (send *FALCON-DEbugger-frame* :status) '(:deactivated))) (setq *FALCON-DEbugger-frame* (make-instance 'FALCON-DEBUGGER-FRAME :activate-p t))) (when select-p (send *FALCON-DEbugger-frame* :select)) *FALCON-DEbugger-frame*) (defun wind-show-user-frame () (send (send *falcon-debugger-frame* :get-pane 'frame-pane) :show-user-frame) ) (defun display-process-internal () (do ((blip (funcall *frame-stream* :any-tyi) (funcall *frame-stream* :any-tyi))) (()) (case (car blip) (:register ;; process the request ) (:call-stack ;; get all information about stack entry and dump them to window frame (let ((line-info (cdr (assoc (second blip) ;(read-from-string (second blip)) (funcall *call-stack-stream* :stack-info))))) (if line-info (funcall *frame-stream* :show-user-frame-from-call-stack-entry line-info) (error nil "Something is screwed"))) ) (:menu (send (fourth blip) :execute (second blip)) ) ) ) ) (defun display-process (&rest ignore) (let ((*command-menu* (funcall *falcon-debugger-frame* :get-pane 'menu-pane)) (*frame-stream* (funcall *falcon-debugger-frame* :get-pane 'frame-pane)) (*call-stack-stream* (funcall *falcon-debugger-frame* :get-pane 'call-stack-pane)) (*terminal-io* (send *falcon-debugger-frame* :get-pane 'debug-pane))) ; (*catch 'foo (display-process-internal) ; ) ) ) (compile-flavor-methods wimp-pane kbug2-pane CALL-STACK-FLAVOR FALCON-DEBUGGER-FRAME) (tv:add-system-key #\K '(wbug nil) "FALCON Debugger" nil)