411 lines
14 KiB
ArmAsm
411 lines
14 KiB
ArmAsm
|
; -*- Mode: Lisp -*- Filename: pdebug.s
|
|||
|
|
|
|||
|
|
;--------------------------------------------------------------------------;
|
|||
|
|
; ;
|
|||
|
|
; TI SCHEME -- PCS Compiler ;
|
|||
|
|
; Copyright 1985 (c) Texas Instruments ;
|
|||
|
|
; ;
|
|||
|
|
; David Bartley ;
|
|||
|
|
; ;
|
|||
|
|
; System Debugger and Error Handlers ;
|
|||
|
|
; ;
|
|||
|
|
;--------------------------------------------------------------------------;
|
|||
|
|
|
|||
|
|
; Revision history:
|
|||
|
|
; db 10/18/85 - ??
|
|||
|
|
; tc 03/13/87 - Extended errors for DOS I/O errors
|
|||
|
|
|
|||
|
|
|
|||
|
|
; The following definitions are used only at compile time for readability
|
|||
|
|
; and understanding. They will not be written out to the .so file.
|
|||
|
|
; See pboot.s and compile.all.
|
|||
|
|
|
|||
|
|
(compile-time-alias IO-ERRORS-START 21)
|
|||
|
|
(compile-time-alias IO-ERRORS-END 108)
|
|||
|
|
(compile-time-alias DOS-IO-ERROR 21)
|
|||
|
|
(compile-time-alias FILE-NOT-FOUND 22)
|
|||
|
|
(compile-time-alias PATH-NOT-FOUND 23)
|
|||
|
|
(compile-time-alias TOO-MANY-FILES 24)
|
|||
|
|
|
|||
|
|
(define assert-procedure)
|
|||
|
|
(define breakpoint-procedure)
|
|||
|
|
(define error-procedure)
|
|||
|
|
(define *error-handler*)
|
|||
|
|
|
|||
|
|
(letrec
|
|||
|
|
((uv-msg
|
|||
|
|
'(1 2 3 4))
|
|||
|
|
(msg-codes
|
|||
|
|
'((0 . "Unspecified VM error")
|
|||
|
|
(1 . "Variable not defined in current environment")
|
|||
|
|
(2 . "SET! of an unbound variable")
|
|||
|
|
(3 . "Variable not defined in lexical environment")
|
|||
|
|
(4 . "SET! of an unbound lexical variable")
|
|||
|
|
(5 . "Variable not defined in fluid environment")
|
|||
|
|
(6 . "SET-FLUID! of an unbound fluid variable")
|
|||
|
|
(7 . "Vector index out of range")
|
|||
|
|
(8 . "String index out of range")
|
|||
|
|
(9 . "Invalid substring range") ; not generated
|
|||
|
|
(10 . "Invalid operand to VM instruction")
|
|||
|
|
(11 . "User keyboard interrupt")
|
|||
|
|
(12 . "Attempt to call a non-procedural object")
|
|||
|
|
;; (13 . "Engine Timer Interrupt")
|
|||
|
|
(14 . "I/O attempted to a de-exposed window")
|
|||
|
|
;; 14 is a trap for a window handler, not a real error
|
|||
|
|
(15 . "FLONUM overflow or underflow")
|
|||
|
|
(16 . "Divide by zero")
|
|||
|
|
(17 . "Non-numeric operand to arithmetic operation")
|
|||
|
|
(18 . "Register overflow--Too many arguments to closure")
|
|||
|
|
(19 . "MAKE-VECTOR size limit exceeded")
|
|||
|
|
(20 . "MAKE-STRING size limit exceeded")
|
|||
|
|
(21 . "DOS I/O error number ")
|
|||
|
|
(22 . "DOS I/O error - File not found")
|
|||
|
|
(23 . "DOS I/O error - Path not found")
|
|||
|
|
(24 . "DOS I/O error - Too many open files")
|
|||
|
|
(25 . "DOS I/O error - Access denied")
|
|||
|
|
(32 . "DOS I/O error - Invalid access")
|
|||
|
|
(36 . "DOS I/O error - Invalid disk drive")
|
|||
|
|
(39 . "DOS I/O error - Disk write protected")
|
|||
|
|
(41 . "DOS I/O error - Drive not ready")
|
|||
|
|
(48 . "DOS I/O error - Printer out of paper")
|
|||
|
|
(200 . "DOS I/O error - Disk Full")
|
|||
|
|
))
|
|||
|
|
(oops
|
|||
|
|
(lambda (msg irritant env stk-index kind error-code)
|
|||
|
|
(fluid-let ((input-port standard-input)
|
|||
|
|
(output-port standard-output))
|
|||
|
|
(let* ((si (if (negative? stk-index)
|
|||
|
|
(%reify-stack (+ (%reify-stack -1) 6))
|
|||
|
|
stk-index))
|
|||
|
|
(env (if (null? env)
|
|||
|
|
(%reify-stack (+ si 9))
|
|||
|
|
env)))
|
|||
|
|
(newline)
|
|||
|
|
(display kind)
|
|||
|
|
(when msg (display msg))
|
|||
|
|
(newline)
|
|||
|
|
(write irritant)
|
|||
|
|
(newline)
|
|||
|
|
(pcs-kill-engine)
|
|||
|
|
|
|||
|
|
(if (unbound? compile)
|
|||
|
|
;; see if compiler auto-loadable
|
|||
|
|
(when (not (pcs-autoload-binding 'compile))
|
|||
|
|
;; Cant find compiler, punt
|
|||
|
|
(display (integer->char 7)) ;beep
|
|||
|
|
(display "Press a key to return to toplevel, escape to exit to DOS")
|
|||
|
|
(let ((ch (read-char)))
|
|||
|
|
(if (char=? ch #\escape)
|
|||
|
|
(exit)
|
|||
|
|
(scheme-reset))))
|
|||
|
|
;else
|
|||
|
|
(if (null? (%env-lu '%inspector user-initial-environment))
|
|||
|
|
;; check to see if we can load the inspector
|
|||
|
|
(when (or (eqv? *error-message* TOO-MANY-FILES)
|
|||
|
|
(null? (pcs-autoload-binding '%inspector)))
|
|||
|
|
(display "Unable to autoload the inspector - file PINSPECT.FSL")
|
|||
|
|
(reset))))
|
|||
|
|
|
|||
|
|
(%inspector msg kind irritant env si error-code)
|
|||
|
|
|
|||
|
|
))))
|
|||
|
|
(envoke-handler
|
|||
|
|
(lambda (number msg irritant stk-index err-code)
|
|||
|
|
(let ((handler (lambda ()
|
|||
|
|
(oops msg
|
|||
|
|
irritant
|
|||
|
|
'()
|
|||
|
|
stk-index
|
|||
|
|
"[VM ERROR encountered!] "
|
|||
|
|
err-code))))
|
|||
|
|
(if (closure? *user-error-handler*)
|
|||
|
|
(*user-error-handler* number
|
|||
|
|
msg
|
|||
|
|
irritant
|
|||
|
|
handler)
|
|||
|
|
(handler)))))
|
|||
|
|
(decipher-error
|
|||
|
|
(lambda (stk-index)
|
|||
|
|
(let ((err-code *error-code*)
|
|||
|
|
(irritant *irritant*)
|
|||
|
|
(err-num (and (number? *error-message*) *error-message*))
|
|||
|
|
(msg (apply-if (assv *error-message* msg-codes)
|
|||
|
|
cdr
|
|||
|
|
*error-message*)))
|
|||
|
|
(cond ((eqv? err-num 11) ; Shift Break
|
|||
|
|
(set! err-num 100))
|
|||
|
|
((and err-num ; I/O Errors
|
|||
|
|
(>= err-num IO-ERRORS-START)
|
|||
|
|
(<= err-num IO-ERRORS-END))
|
|||
|
|
(if (and (or (=? err-num FILE-NOT-FOUND)
|
|||
|
|
(=? err-num PATH-NOT-FOUND))
|
|||
|
|
(fluid-bound? *file-exists-open*))
|
|||
|
|
((fluid *file-exists-open*) #!false)) ; error continuation
|
|||
|
|
|
|||
|
|
(set! err-num (- err-num (-1+ DOS-IO-ERROR)))
|
|||
|
|
(if (number? msg)
|
|||
|
|
(set! msg (string-append (cdr (assv DOS-IO-ERROR msg-codes))
|
|||
|
|
(integer->string err-num 10))))))
|
|||
|
|
(envoke-handler err-num msg irritant stk-index err-code))))
|
|||
|
|
) ; letrec vars
|
|||
|
|
|
|||
|
|
(begin
|
|||
|
|
(set! assert-procedure ; ASSERT-PROCEDURE
|
|||
|
|
(lambda (msgs env)
|
|||
|
|
(oops '() (cons 'ASSERT (cons '() msgs)) env -1 "[ASSERT failure!] " 0)))
|
|||
|
|
|
|||
|
|
(set! breakpoint-procedure ; BREAKPOINT-PROCEDURE
|
|||
|
|
(lambda (msg irritant env . rest)
|
|||
|
|
(let* ((stk-index (if (or (null? rest)
|
|||
|
|
(not (integer? (car rest))))
|
|||
|
|
-1
|
|||
|
|
(car rest))))
|
|||
|
|
(oops msg irritant env stk-index "[BKPT encountered!] " 0))))
|
|||
|
|
|
|||
|
|
(set! error-procedure ; ERROR-PROCEDURE
|
|||
|
|
(lambda (msg irritant env)
|
|||
|
|
(let ((system-error-handler
|
|||
|
|
(lambda ()
|
|||
|
|
(oops msg irritant env -1 "[ERROR encountered!] " 0))))
|
|||
|
|
(if (closure? *user-error-handler*)
|
|||
|
|
(begin
|
|||
|
|
(*user-error-handler* '() msg irritant system-error-handler))
|
|||
|
|
;else
|
|||
|
|
(system-error-handler)))))
|
|||
|
|
|
|||
|
|
(set! *error-handler* ; *ERROR-HANDLER*
|
|||
|
|
(lambda ()
|
|||
|
|
(cond ((and (zero? *error-code*) ; resumable
|
|||
|
|
(memv *error-message* uv-msg)) ; unbound symbol
|
|||
|
|
(if (pcs-autoload-binding *irritant*)
|
|||
|
|
'() ; autoload worked!
|
|||
|
|
;else
|
|||
|
|
(let ((info (getprop *irritant* 'PCS*PRIMOP-HANDLER))
|
|||
|
|
(compiler-present (or (not (unbound? compile))
|
|||
|
|
(pcs-autoload-binding 'compile))))
|
|||
|
|
(cond ((and compiler-present
|
|||
|
|
(integer? info)
|
|||
|
|
(getprop *irritant* 'PCS*OPCODE))
|
|||
|
|
(let* ((vars '(J I H G F E D C B A))
|
|||
|
|
(bvl (list-tail vars (- (length vars) info)))
|
|||
|
|
(form `(define ,*irritant*
|
|||
|
|
(lambda ,bvl
|
|||
|
|
(,*irritant* . ,bvl))))
|
|||
|
|
(dw pcs-display-warnings)
|
|||
|
|
(ip pcs-integrate-primitives))
|
|||
|
|
(set! pcs-display-warnings #!false)
|
|||
|
|
(set! pcs-integrate-primitives #!true)
|
|||
|
|
(eval form user-global-environment)
|
|||
|
|
(set! pcs-display-warnings dw)
|
|||
|
|
(set! pcs-integrate-primitives ip)
|
|||
|
|
'()))
|
|||
|
|
((and compiler-present
|
|||
|
|
(pair? info)
|
|||
|
|
(eq? (car info) 'DEFINE-INTEGRABLE))
|
|||
|
|
(let ((form `(define ,*irritant* ,(cdr info)))
|
|||
|
|
(dw pcs-display-warnings)
|
|||
|
|
(ip pcs-integrate-primitives))
|
|||
|
|
(set! pcs-display-warnings #!false)
|
|||
|
|
(set! pcs-integrate-primitives #!true)
|
|||
|
|
(eval form user-initial-environment)
|
|||
|
|
(set! pcs-display-warnings dw)
|
|||
|
|
(set! pcs-integrate-primitives ip)
|
|||
|
|
'()))
|
|||
|
|
(else
|
|||
|
|
(set! *error-message*
|
|||
|
|
(cdr (assv *error-message* msg-codes)))
|
|||
|
|
(*error-handler*))))))
|
|||
|
|
((eqv? *error-message* 13)
|
|||
|
|
(pcs-engine-timeout)) ; Engine Timeout
|
|||
|
|
(else
|
|||
|
|
(decipher-error (%reify-stack
|
|||
|
|
(+ (%reify-stack
|
|||
|
|
(+ (%reify-stack -1) 6)) 6)))))
|
|||
|
|
) ;lambda
|
|||
|
|
) ;set!
|
|||
|
|
) ;begin
|
|||
|
|
) ;letrec
|
|||
|
|
|
|||
|
|
(define autoload-from-file ; AUTOLOAD-FROM-FILE
|
|||
|
|
(lambda (file names . rest)
|
|||
|
|
(let ((env (if rest (car rest) user-initial-environment)))
|
|||
|
|
(putprop 'PCS-AUTOLOAD-INFO
|
|||
|
|
(cons (list file names env)
|
|||
|
|
(getprop 'PCS-AUTOLOAD-INFO
|
|||
|
|
'PCS-AUTOLOAD-INFO))
|
|||
|
|
'PCS-AUTOLOAD-INFO)
|
|||
|
|
'())))
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define pcs-autoload-binding '()) ; PCS-AUTOLOAD-BINDING
|
|||
|
|
(define remove-autoload-info '()) ; REMOVE-AUTOLOAD-INFO
|
|||
|
|
|
|||
|
|
(letrec
|
|||
|
|
((find-entry
|
|||
|
|
(lambda (name info)
|
|||
|
|
(and info
|
|||
|
|
(or (symbol? name) (string? name))
|
|||
|
|
(find-item name (caar info)(cadar info) info))))
|
|||
|
|
(find-item
|
|||
|
|
(lambda (name file symbols info)
|
|||
|
|
(cond ((string? name)
|
|||
|
|
(if (string-ci=? name file)
|
|||
|
|
(car info)
|
|||
|
|
(find-entry name (cdr info))))
|
|||
|
|
((null? symbols)
|
|||
|
|
(find-entry name (cdr info)))
|
|||
|
|
((eq? name (car symbols))
|
|||
|
|
(car info))
|
|||
|
|
(else
|
|||
|
|
(find-item name file (cdr symbols) info))))))
|
|||
|
|
(set! pcs-autoload-binding
|
|||
|
|
(lambda (name)
|
|||
|
|
(let* ((info (getprop 'PCS-AUTOLOAD-INFO 'PCS-AUTOLOAD-INFO))
|
|||
|
|
(entry (find-entry name info)))
|
|||
|
|
(and entry
|
|||
|
|
(let ((file (car entry))
|
|||
|
|
(env (caddr entry)))
|
|||
|
|
(and (string? file)
|
|||
|
|
(file-exists? file)
|
|||
|
|
(let ((saved-env (%set-global-environment env)))
|
|||
|
|
(load file)
|
|||
|
|
(%set-global-environment saved-env)
|
|||
|
|
(not (null? (%env-lu name env)))
|
|||
|
|
)))))))
|
|||
|
|
(set! remove-autoload-info
|
|||
|
|
(lambda (filename)
|
|||
|
|
(let* ((info (getprop 'PCS-AUTOLOAD-INFO 'PCS-AUTOLOAD-INFO))
|
|||
|
|
(entry (find-entry (%system-file-name filename) info)))
|
|||
|
|
(and entry
|
|||
|
|
(putprop 'PCS-AUTOLOAD-INFO
|
|||
|
|
(delq! entry
|
|||
|
|
(getprop 'PCS-AUTOLOAD-INFO
|
|||
|
|
'PCS-AUTOLOAD-INFO))
|
|||
|
|
'PCS-AUTOLOAD-INFO)))))
|
|||
|
|
)
|
|||
|
|
|
|||
|
|
(define environment-bindings ; ENVIRONMENT-BINDINGS
|
|||
|
|
(letrec
|
|||
|
|
((linked-bindings
|
|||
|
|
(lambda (a-list names values)
|
|||
|
|
(if (null? names)
|
|||
|
|
(reverse! a-list)
|
|||
|
|
(linked-bindings (cons (cons (car names)(cdr values))
|
|||
|
|
a-list)
|
|||
|
|
(cdr names)
|
|||
|
|
(car values)))))
|
|||
|
|
(hashed-bindings
|
|||
|
|
(lambda (a-list index env)
|
|||
|
|
(if (zero? index)
|
|||
|
|
a-list
|
|||
|
|
(let ((bucket (%reify env index)))
|
|||
|
|
(hashed-bindings (if (null? bucket)
|
|||
|
|
a-list
|
|||
|
|
(bucket-bindings a-list bucket))
|
|||
|
|
(- index 1)
|
|||
|
|
env)))))
|
|||
|
|
(bucket-bindings
|
|||
|
|
(lambda (a-list bucket)
|
|||
|
|
(if (null? bucket)
|
|||
|
|
a-list
|
|||
|
|
(bucket-bindings (cons (car bucket) a-list)
|
|||
|
|
(cdr bucket))))))
|
|||
|
|
(lambda (obj)
|
|||
|
|
(if (null? obj)
|
|||
|
|
obj
|
|||
|
|
(let* ((env (cond ((environment? obj) ; environment?
|
|||
|
|
obj)
|
|||
|
|
((or (closure? obj) ; closure?
|
|||
|
|
(delayed-object? obj)) ; delayed object?
|
|||
|
|
(procedure-environment obj))
|
|||
|
|
(else
|
|||
|
|
(%error-invalid-operand 'ENVIRONMENT-BINDINGS
|
|||
|
|
obj))))
|
|||
|
|
(size (%reify env -1)))
|
|||
|
|
(if (= size 12)
|
|||
|
|
(linked-bindings '() (%reify env 1) (%reify env 2))
|
|||
|
|
(hashed-bindings '() (- (quotient size 3) 2) env)))))))
|
|||
|
|
|
|||
|
|
|
|||
|
|
;;;
|
|||
|
|
;;; UNBIND is a function which will remove a variable's binding from a given
|
|||
|
|
;;; environment. It will work for either of the 2 global environments
|
|||
|
|
;;; (USER-GLOBAL-ENVIRONMENT and USER-INITIAL-ENVIRONMENT) or for any other
|
|||
|
|
;;; heap allocated environments. Removing the binding from the environment
|
|||
|
|
;;; will allow the garbage collector to reclaim that space. Also, once
|
|||
|
|
;;; unbound, the autoloader may reload the variable whenever that variable
|
|||
|
|
;;; is referenced again.
|
|||
|
|
;;;
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define unbind
|
|||
|
|
(letrec
|
|||
|
|
((remove-hashed-binding!
|
|||
|
|
(lambda (key alist)
|
|||
|
|
(cond ((null? (cadr alist))
|
|||
|
|
'())
|
|||
|
|
((eq? key (caadr alist))
|
|||
|
|
(set-cdr! alist (cddr alist)))
|
|||
|
|
(else
|
|||
|
|
(remove-hashed-binding! key (cdr alist))))))
|
|||
|
|
|
|||
|
|
(modify-hashed-env!
|
|||
|
|
(lambda (symbol env)
|
|||
|
|
(let* ((hash-val (1+ (%esc2 9 (symbol->string symbol))))
|
|||
|
|
(sym-list (%reify env hash-val)))
|
|||
|
|
|
|||
|
|
(if (null? sym-list)
|
|||
|
|
'()
|
|||
|
|
;else
|
|||
|
|
(begin
|
|||
|
|
(if (eq? symbol (caar sym-list))
|
|||
|
|
(set! sym-list (cdr sym-list))
|
|||
|
|
;else
|
|||
|
|
(remove-hashed-binding! symbol sym-list))
|
|||
|
|
(%reify! env hash-val sym-list)
|
|||
|
|
env)))))
|
|||
|
|
|
|||
|
|
(remove-linked-binding!
|
|||
|
|
(lambda (key names values)
|
|||
|
|
(cond ((null? (cadr names))
|
|||
|
|
'())
|
|||
|
|
((eq? key (cadr names))
|
|||
|
|
(set-cdr! names (cddr names))
|
|||
|
|
(set-car! values (caar values)))
|
|||
|
|
(else
|
|||
|
|
(remove-linked-binding! key (cdr names) (car values))))))
|
|||
|
|
|
|||
|
|
(modify-linked-env!
|
|||
|
|
(lambda (symbol env names values)
|
|||
|
|
(if (eq? symbol (car names))
|
|||
|
|
(begin
|
|||
|
|
(set! names (cdr names))
|
|||
|
|
(set! values (car values)))
|
|||
|
|
;else
|
|||
|
|
(remove-linked-binding! symbol names values))
|
|||
|
|
(%reify! env 1 names)
|
|||
|
|
(%reify! env 2 values)))
|
|||
|
|
)
|
|||
|
|
|
|||
|
|
(lambda (symbol env)
|
|||
|
|
(cond ((not (symbol? symbol))
|
|||
|
|
(%error-invalid-operand 'UNBIND symbol))
|
|||
|
|
((not (environment? env))
|
|||
|
|
(%error-invalid-operand 'UNBIND env))
|
|||
|
|
(else
|
|||
|
|
(if (= (%reify env -1) 12)
|
|||
|
|
(modify-linked-env! symbol env (%reify env 1) (%reify env 2))
|
|||
|
|
;
|
|||
|
|
(modify-hashed-env! symbol env)))))))
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define (procedure-environment obj) ; PROCEDURE-ENVIRONMENT
|
|||
|
|
(cond ((closure? obj)
|
|||
|
|
(%reify obj 1))
|
|||
|
|
((delayed-object? obj)
|
|||
|
|
(procedure-environment (vector-ref obj 1)))
|
|||
|
|
(else
|
|||
|
|
(%error-invalid-operand 'PROCEDURE-ENVIRONMENT obj))))
|
|||
|
|
|
|||
|
|
|