Merge branch 'Issue705.3'

lib/r7rs.stk

@@ -1,7 +1,7 @@
 ;;;;
 ;;;; r7rs.stk   -- R7RS support (Draft-3)
 ;;;;
-;;;; Copyright © 2011-2024 Erick Gallesio <[email protected]>
+;;;; Copyright © 2011-2025 Erick Gallesio <[email protected]>
 ;;;;
 ;;;;
 ;;;; This program is free software; you can redistribute it and/or modify
@@ -1551,24 +1551,25 @@ doc>
          (ex       (gensym))
          (old-hdlr (gensym))
          (reraised (gensym))
-         (res      (gensym)))
-    `(let ((,old-hdlr (current-exception-handler)))
+         (res      (gensym))
+         (clauses  (if (and (pair? last)         ;; Add an else clause if not present
+                            (pair? (car last))
+                            (eq? (caar last) 'else))
+                       (cdr clauses)
+                       (append (cdr clauses)
+                               `((else (set! ,reraised #t)
+                                       (,old-hdlr ,ex)))))))
+    `(let ((,old-hdlr ( [%%symbol-value 'current-exception-handler 'SCHEME] )))
        (with-handler
         (lambda (,ex)
-          (let* ((,var (if (%continuable-exception? ,ex)
-                           (%continuable-exception-value ,ex)
+          (let* ((,var (if ([%%symbol-value '%continuable-exception? 'SCHEME] ,ex)
+                           ([%%symbol-value '%continuable-exception-value 'SCHEME] ,ex)
                            ,ex))
                  (,reraised #f)
-                 (,res (cond
-                        ,@(cdr clauses)
-                           ;; Add an else clause if not present
-                        ,@(if (and (pair? last) (pair? (car last)) (eq? (caar last) 'else))
-                              '()
-                              `((else (set! ,reraised #t)
-                                      (,old-hdlr ,ex)))))))
+                 (,res (cond ,@clauses)))
             (if ,reraised
                 ,res
-                (if (%continuable-exception? ,ex)
+                (if ([%%symbol-value '%continuable-exception? 'SCHEME] ,ex)
                     (raise ,res)
                     ,res))))
         ,@body))))

src/boot.c

@@ -1763,7 +1763,7 @@ char* STk_boot_consts = "#("
 "current-exception-handler" " "
 "raise-continuable" " "
 "guard" " "
-"(lambda (clauses . body) (let* ((var (car clauses)) (last (last-pair clauses)) (ex (gensym)) (old-hdlr (gensym)) (reraised (gensym)) (res (gensym))) `(let ((,old-hdlr (current-exception-handler))) (with-handler (lambda (,ex) (let* ((,var (if (%continuable-exception? ,ex) (%continuable-exception-value ,ex) ,ex)) (,reraised #f) (,res (cond ,@(cdr clauses) ,@(if (and (pair? last) (pair? (car last)) (eq? (caar last) 'else)) '() `((else (set! ,reraised #t) (,old-hdlr ,ex))))))) (if ,reraised ,res (if (%continuable-exception? ,ex) (raise ,res) ,res)))) ,@body))))" " "
+"(lambda (clauses . body) (let* ((var (car clauses)) (last (last-pair clauses)) (ex (gensym)) (old-hdlr (gensym)) (reraised (gensym)) (res (gensym)) (clauses (if (and (pair? last) (pair? (car last)) (eq? (caar last) 'else)) (cdr clauses) (append (cdr clauses) `((else (set! ,reraised #t) (,old-hdlr ,ex))))))) `(let ((,old-hdlr ((%%symbol-value 'current-exception-handler 'SCHEME)))) (with-handler (lambda (,ex) (let* ((,var (if ((%%symbol-value '%continuable-exception? 'SCHEME) ,ex) ((%%symbol-value '%continuable-exception-value 'SCHEME) ,ex) ,ex)) (,reraised #f) (,res (cond ,@clauses))) (if ,reraised ,res (if ((%%symbol-value '%continuable-exception? 'SCHEME) ,ex) (raise ,res) ,res)))) ,@body))))" " "
 "current-jiffy" " "
 "jiffies-per-second" " "
 "*all-features*" " "
@@ -23208,7 +23208,7 @@ STk_instr STk_boot_code [] = {
 0xa,
 0x7d,
 0x2d,
-0x6718,
+0x6773,
 0x25,
 0x55,
 0xf5,
@@ -46142,10 +46142,10 @@ STk_instr STk_boot_code [] = {
 0x55,
 0x6dc,
 0x23,
-0xe6,
+0x141,
 0xfffe,
 0x2a,
-0x6,
+0x7,
 0x12,
 0x101,
 0x3d,
@@ -46178,13 +46178,100 @@ STk_instr STk_boot_code [] = {
 0x0,
 0x1a,
 0x5,
+0x25,
+0x66,
+0x56,
+0x38,
+0x1,
+0x1d,
+0x11,
+0x25,
+0xd,
+0x3d,
+0x71,
+0x38,
+0x1,
+0x1d,
+0x9,
+0xd,
+0x48,
+0x0,
+0x21,
+0x9,
+0x2fb,
+0x45,
+0x1c,
+0x1,
+0x1,
+0x1d,
+0x5,
+0x12,
+0x101,
+0x3e,
+0x1c,
+0x20,
+0x25,
+0x12,
+0x101,
+0x3e,
+0x21,
+0x55,
+0x2fb,
+0x55,
+0x91,
+0x69,
+0x4e,
+0x3,
+0x3b,
+0x3b,
+0x3b,
+0x21,
+0x68,
+0x67,
+0x3,
+0x3b,
+0x3b,
+0x21,
+0x3,
+0x3b,
+0x3b,
+0x3b,
+0x21,
+0x3,
+0x3b,
+0x71,
+0x41,
+0x2,
+0x1a,
+0x6,
 0x55,
 0x68,
 0x68,
 0x55,
+0xa7,
+0x55,
+0x6b,
+0x55,
 0x6d9,
 0x3,
 0x3b,
+0x3b,
+0x21,
+0x55,
+0x6b,
+0x55,
+0xf5,
+0x3,
+0x3b,
+0x3b,
+0x21,
+0x3,
+0x3b,
+0x3b,
+0x3b,
+0x21,
+0x3,
+0x3b,
 0x21,
 0x3,
 0x3b,
@@ -46207,102 +46294,85 @@ STk_instr STk_boot_code [] = {
 0x55,
 0x8a,
 0x55,
+0xa7,
+0x55,
+0x6b,
+0x55,
 0x6d5,
-0x67,
 0x3,
 0x3b,
 0x3b,
 0x21,
 0x55,
-0x6d6,
-0x67,
+0x6b,
+0x55,
+0xf5,
 0x3,
 0x3b,
 0x3b,
 0x21,
-0x67,
 0x3,
 0x3b,
 0x3b,
 0x3b,
-0x3b,
 0x21,
+0x67,
 0x3,
 0x3b,
 0x3b,
 0x21,
-0x69,
-0x4d,
+0x55,
+0xa7,
+0x55,
+0x6b,
+0x55,
+0x6d6,
 0x3,
 0x3b,
 0x3b,
 0x21,
-0x11,
-0x5,
-0x21,
 0x55,
-0x2f9,
-0x25,
-0x12,
-0x101,
-0x3e,
-0x6e,
-0x66,
-0x56,
-0x38,
-0x1,
-0x1d,
-0x11,
-0x25,
-0xd,
-0x3d,
-0x71,
-0x38,
-0x1,
-0x1d,
-0x9,
-0xd,
-0x48,
-0x0,
-0x21,
-0x9,
-0x2fb,
-0x45,
-0x1c,
-0x1,
-0x1,
-0x1d,
-0x3,
-0x3,
-0x1c,
-0x18,
-0x55,
-0x2fb,
+0x6b,
 0x55,
-0x91,
-0x69,
-0x4e,
+0xf5,
+0x3,
+0x3b,
+0x3b,
+0x21,
 0x3,
 0x3b,
 0x3b,
 0x3b,
 0x21,
-0x68,
 0x67,
 0x3,
 0x3b,
 0x3b,
 0x21,
+0x67,
 0x3,
 0x3b,
 0x3b,
 0x3b,
+0x3b,
 0x21,
 0x3,
 0x3b,
-0x71,
-0x41,
-0x2,
+0x3b,
+0x21,
+0x69,
+0x4d,
+0x3,
+0x3b,
+0x3b,
+0x21,
+0x11,
+0x5,
+0x21,
+0x55,
+0x2f9,
+0x11,
+0x6,
 0x3b,
 0x21,
 0x3,
@@ -46323,7 +46393,28 @@ STk_instr STk_boot_code [] = {
 0x55,
 0x8a,
 0x55,
+0xa7,
+0x55,
+0x6b,
+0x55,
 0x6d5,
+0x3,
+0x3b,
+0x3b,
+0x21,
+0x55,
+0x6b,
+0x55,
+0xf5,
+0x3,
+0x3b,
+0x3b,
+0x21,
+0x3,
+0x3b,
+0x3b,
+0x3b,
+0x21,
 0x67,
 0x3,
 0x3b,