diff --git a/src/package.lisp b/src/package.lisp index 6711164..4e2c616 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -123,9 +123,14 @@ #:rt-make-instance-0 #:*rt-class-registry* #:*rt-generic-function-registry* ;; Conditions - #:rt-runtime-condition #:rt-runtime-error + #:rt-runtime-condition #:rt-runtime-error #:rt-serious-condition #:rt-warning + #:rt-type-error #:rt-simple-type-error #:rt-program-error #:rt-control-error + #:rt-storage-condition #:rt-stream-error #:rt-file-error #:rt-cell-error + #:rt-unbound-variable #:rt-undefined-function #:rt-arithmetic-error + #:rt-division-by-zero #:rt-floating-point-overflow #:rt-floating-point-underflow #:rt-signal-error #:rt-signal #:rt-warn-fn #:rt-cerror #:rt-invoke-restart + #:*rt-debugger-hook* #:rt-invoke-debugger-hook #:rt-with-debugger-hook #:*handler-stack* #:*restart-stack* #:rt-handler #:rt-handler-p #:make-rt-handler #:rt-handler-condition-type #:rt-handler-handler-function @@ -180,6 +185,7 @@ #:+nan-boxing-quiet-nan+ #:+ptr-base+ #:+ptr-mask+ #:+tag-mask+ #:+addr-mask+ #:+tag-object+ #:+tag-cons+ #:+tag-symbol+ #:+tag-function+ #:+tag-string+ + #:+rt-array-type-tag+ #:+rt-array-metadata-version+ #:+tag-char+ #:+fixnum-tag+ #:+fixnum-mask+ #:+fixnum-shift+ #:+val-nil+ #:+val-t+ #:+val-unbound+ diff --git a/src/runtime-conditions.lisp b/src/runtime-conditions.lisp index 8382350..97da450 100644 --- a/src/runtime-conditions.lisp +++ b/src/runtime-conditions.lisp @@ -18,6 +18,47 @@ (define-condition rt-runtime-error (error rt-runtime-condition) () (:documentation "Base of every error cl-cc/runtime signals.")) +;;; ANSI condition taxonomy used by runtime-generated errors. The RT prefix +;;; keeps these classes distinct from host conditions while retaining the +;;; standard superclass relationships callers use with TYPEP. +(define-condition rt-serious-condition (serious-condition rt-runtime-condition) ()) +(define-condition rt-warning (warning rt-runtime-condition) ()) +(define-condition rt-type-error (type-error rt-runtime-error) ()) +(define-condition rt-simple-type-error (simple-type-error rt-type-error) ()) +(define-condition rt-program-error (program-error rt-runtime-error) ()) +(define-condition rt-control-error (control-error rt-runtime-error) ()) +(define-condition rt-storage-condition (storage-condition rt-runtime-error) ()) +(define-condition rt-stream-error (stream-error rt-runtime-error) ()) +(define-condition rt-file-error (file-error rt-stream-error) ()) +(define-condition rt-cell-error (cell-error rt-runtime-error) ()) +(define-condition rt-unbound-variable (unbound-variable rt-cell-error) ()) +(define-condition rt-undefined-function (undefined-function rt-cell-error) ()) +(define-condition rt-arithmetic-error (arithmetic-error rt-runtime-error) ()) +(define-condition rt-division-by-zero (division-by-zero rt-arithmetic-error) ()) +(define-condition rt-floating-point-overflow + (floating-point-overflow rt-arithmetic-error) ()) +(define-condition rt-floating-point-underflow + (floating-point-underflow rt-arithmetic-error) ()) + +(defvar *rt-debugger-hook* nil + "Runtime debugger hook, called with an unhandled condition before escalation. + +The hook receives the condition and must not return a replacement value. A +dynamic binding shadows this variable for one runtime signal, matching the +scope of the host Common Lisp debugger hook without mutating the host hook.") + +(defun rt-invoke-debugger-hook (condition) + "Invoke the current runtime debugger hook for CONDITION, if any." + (when *rt-debugger-hook* + (funcall *rt-debugger-hook* condition)) + condition) + +(defun rt-with-debugger-hook (hook thunk) + "Run THUNK with HOOK installed as the runtime debugger hook." + (check-type thunk (or function symbol rt-closure-obj)) + (let ((*rt-debugger-hook* hook)) + (rt-call-fn thunk))) + (defvar *rt-method-context-stack* nil "Dynamic stack of native-runtime generic-function method contexts. diff --git a/src/runtime-math-io.lisp b/src/runtime-math-io.lisp index bd2c384..8ee2f48 100644 --- a/src/runtime-math-io.lisp +++ b/src/runtime-math-io.lisp @@ -69,7 +69,9 @@ (multiple-value-bind (result handled-p) (rt-dispatch-signal condition) (if handled-p result - (error condition))))) + (progn + (rt-invoke-debugger-hook condition) + (error condition)))))) (defun rt-signal (condition) (%rt-with-signal-gc-inhibit diff --git a/src/runtime-ops.lisp b/src/runtime-ops.lisp index 786fea8..b14ffaf 100644 --- a/src/runtime-ops.lisp +++ b/src/runtime-ops.lisp @@ -10,12 +10,30 @@ ;;; Arrays / Vectors ;;; ------------------------------------------------------------ -(defun rt-make-array (dims &key (element-type t) initial-element fill-pointer adjustable) - (if initial-element - (make-array dims :element-type element-type :initial-element initial-element - :fill-pointer fill-pointer :adjustable adjustable) - (make-array dims :element-type element-type - :fill-pointer fill-pointer :adjustable adjustable))) +(defun rt-make-array (dims &key (element-type t) + (initial-element nil initial-element-p) + (initial-contents nil initial-contents-p) + fill-pointer adjustable + displaced-to displaced-index-offset) + "Create a runtime array while preserving all ANSI array shape options. + +The INITIAL-ELEMENT supplied-p distinction matters for NIL, which is a valid +initial element rather than an omitted keyword. Displaced arrays are kept as +real host arrays so their backing-array identity remains visible to the GC and +FFI integration layers." + (let ((arguments (list :element-type element-type + :fill-pointer fill-pointer + :adjustable adjustable))) + (when initial-element-p + (setf arguments (append arguments (list :initial-element initial-element)))) + (when initial-contents-p + (setf arguments (append arguments (list :initial-contents initial-contents)))) + (when displaced-to + (setf arguments (append arguments + (list :displaced-to displaced-to + :displaced-index-offset + (or displaced-index-offset 0))))) + (apply #'make-array dims arguments))) (defun rt-aref (a &rest indices) (apply #'aref a indices)) (defun rt-aset (a &rest indices-then-value) diff --git a/src/value-tags.lisp b/src/value-tags.lisp index 7f319f5..3eb3ef0 100644 --- a/src/value-tags.lisp +++ b/src/value-tags.lisp @@ -67,6 +67,14 @@ (defconstant +tag-string+ #x0005000000000000 "String sub-tag.") +;;; Managed-heap array metadata tags. NaN-boxed arrays continue to use the +;;; general object pointer tag because the five NaN pointer sub-tags are already +;;; allocated and the next bit pattern aliases the character space. +(defconstant +rt-array-type-tag+ 5 + "Managed-heap object header tag reserved for array storage.") +(defconstant +rt-array-metadata-version+ 1 + "Version of the metadata stored in a managed array's metadata slot.") + ;;; Character: quiet NaN with bit[50] clear but bit[49] set. ;;; Base = #x7FFE_... gives bit[49]=1, bit[50]=0 → distinct from pointers. (defconstant +tag-char+ #x7FFE000000000000 diff --git a/src/value.lisp b/src/value.lisp index 429895d..275a0a5 100644 --- a/src/value.lisp +++ b/src/value.lisp @@ -40,6 +40,12 @@ ;;; ;;; SSO string: bits[63:59]=#b01110, bits[58:3] store up to 7 character ;;; bytes little-endian by index, bits[2:0] store byte length. +;;; +;;; Managed arrays use the general object pointer sub-tag. Their heap header +;;; carries +RT-ARRAY-TYPE-TAG+ and the metadata word records element type, +;;; rank/dimensions, capacity, fill-pointer, displacement, and bit packing. +;;; Host-facing RT-MAKE-ARRAY preserves these properties through the ANSI +;;; array object, so no property is inferred from the pointer tag alone. (in-package :cl-cc/runtime) diff --git a/t/runtime-conditions-test.lisp b/t/runtime-conditions-test.lisp index 52d9570..149dc0d 100644 --- a/t/runtime-conditions-test.lisp +++ b/t/runtime-conditions-test.lisp @@ -62,6 +62,14 @@ (expect result :to-be-null) (expect handled-p :to-be-falsy)))) +(it-sequential + "runtime condition subclasses retain ANSI type relationships." + (let ((condition (make-condition 'cl-cc/runtime:rt-division-by-zero))) + (expect (typep condition 'division-by-zero) :to-be-truthy) + (expect (typep condition 'arithmetic-error) :to-be-truthy) + (expect (typep condition 'cl-cc/runtime:rt-runtime-error) :to-be-truthy) + (expect (typep condition 'cl-cc/runtime:rt-runtime-condition) :to-be-truthy))) + (it-sequential "rt-establish-handler runs its thunk with the handler and pops it afterwards." (let ((cl-cc/runtime::*handler-stack* nil)) diff --git a/t/runtime-ops-test.lisp b/t/runtime-ops-test.lisp index 4a6f41b..0440967 100644 --- a/t/runtime-ops-test.lisp +++ b/t/runtime-ops-test.lisp @@ -59,6 +59,17 @@ (expect to :to-be base) (expect offset :to-equal 1)))) +(it-sequential + "rt-make-array accepts displaced-to and preserves writes through the base." + (let* ((base (cl-cc/runtime:rt-make-array 4 :initial-element 0)) + (disp (cl-cc/runtime:rt-make-array 2 :displaced-to base + :displaced-index-offset 1))) + (cl-cc/runtime:rt-aset disp 0 42) + (expect (cl-cc/runtime:rt-aref base 1) :to-equal 42) + (multiple-value-bind (to offset) (cl-cc/runtime:rt-array-displacement disp) + (expect to :to-be base) + (expect offset :to-equal 1)))) + (it-sequential "rt-array-has-fill-pointer-p / rt-array-adjustable-p return 0 for simple arrays." (let ((a (cl-cc/runtime:rt-make-array 3)))