Raymond Toy pushed to branch issue-291-pprint-handler-case at cmucl / cmucl

Commits: e2c9eeea by Raymond Toy at 2024-03-25T14:33:02+00:00 Fix #290: Neatly pprint with-float-traps-masked and friends

- - - - - 8ed3d1d3 by Raymond Toy at 2024-03-25T14:33:07+00:00 Merge branch 'issue-290-pprint-with-float-traps' into 'master'

Fix #290: Neatly pprint with-float-traps-masked and friends

Closes #290

See merge request cmucl/cmucl!199 - - - - - e35e7327 by Raymond Toy at 2024-03-25T07:39:35-07:00 Merge branch 'master' into issue-291-pprint-handler-case

- - - - - 41522236 by Raymond Toy at 2024-03-25T08:16:46-07:00 Fix up typos in comments

- - - - -

2 changed files:

- src/code/pprint.lisp - tests/pprint.lisp

Changes:

===================================== src/code/pprint.lisp ===================================== @@ -1460,8 +1460,8 @@ When annotations are present, invoke them at the right positions."

(defun pprint-handler-case (stream list &rest noise) (declare (ignore noise)) - ;; Like pprint-handler-bind, but the each of the error clauses is - ;; printed with declaractions and forms on a separate line, indented + ;; Like pprint-handler-bind, but each of the error clauses is + ;; printed with declarations and forms on a separate line, indented ;; like a function body. The handler-case part, "~:<~^~W~3I ;; ~:_~W~1I~@{ ~:@_...~:>" comes from pprint-handler-bind, but the ;; last "~W" is replaced to print out the error clauses in the way @@ -2089,7 +2089,9 @@ When annotations are present, invoke them at the right positions." (c:sc-case pprint-sc-case) (c:define-assembly-routine pprint-define-assembly) (c:deftransform pprint-defun) - (c:defoptimizer pprint-defun))) + (c:defoptimizer pprint-defun) + (ext:with-float-traps-masked pprint-with-like) + (ext:with-float-traps-enabled pprint-with-like)))

(defun pprint-init () (setf *initial-pprint-dispatch* (make-pprint-dispatch-table))

===================================== tests/pprint.lisp ===================================== @@ -10,21 +10,10 @@ (assert-equal " (WITH-FLOAT-TRAPS-MASKED (:UNDERFLOW) - (LET* ((RATIO - (/ (* (EXPT 10 PPRINT-TESTS::EXPONENT) NUMBER) - PPRINT-TESTS::DIVISOR)) - (PPRINT-TESTS::RESULT (COERCE RATIO PPRINT-TESTS::FLOAT-FORMAT))) - (WHEN (AND (ZEROP PPRINT-TESTS::RESULT) (NOT (ZEROP NUMBER))) - (ERROR "Underflow")) - PPRINT-TESTS::RESULT))" + (PRINT "Hello"))" (with-output-to-string (s) (pprint '(ext:with-float-traps-masked (:underflow) - (let* ((ratio (/ (* (expt 10 exponent) number) - divisor)) - (result (coerce ratio float-format))) - (when (and (zerop result) (not (zerop number))) - (error "Underflow")) - result)) + (print "Hello")) s))))

(define-test pprint.with-float-traps-enabled @@ -32,21 +21,10 @@ (assert-equal " (WITH-FLOAT-TRAPS-ENABLED (:UNDERFLOW) - (LET* ((RATIO - (/ (* (EXPT 10 PPRINT-TESTS::EXPONENT) NUMBER) - PPRINT-TESTS::DIVISOR)) - (PPRINT-TESTS::RESULT (COERCE RATIO PPRINT-TESTS::FLOAT-FORMAT))) - (WHEN (AND (ZEROP PPRINT-TESTS::RESULT) (NOT (ZEROP NUMBER))) - (ERROR "Underflow")) - PPRINT-TESTS::RESULT))" + (PRINT "Hello"))" (with-output-to-string (s) (pprint '(ext:with-float-traps-enabled (:underflow) - (let* ((ratio (/ (* (expt 10 exponent) number) - divisor)) - (result (coerce ratio float-format))) - (when (and (zerop result) (not (zerop number))) - (error "Underflow")) - result)) + (print "Hello")) s))))

(define-test pprint.handler-case

View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/2f62e54cd7d4de4b46b8415...