411 lines
14 KiB
Common Lisp
411 lines
14 KiB
Common Lisp
; -*- 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))))
|
||
|
||
|