elisp I/O

[bpt/guile.git] / module / language / elisp / boot.el

diff --git a/module/language/elisp/boot.el b/module/language/elisp/boot.el
index f14ab46..bec32b5 100644 (file)
--- a/module/language/elisp/boot.el
+++ b/module/language/elisp/boot.el
@@ -40,8 +40,8 @@
     (if list (%funcall (@ (guile) cdr) list) nil))
   (defun make-symbol (name)
     (%funcall (@ (guile) make-symbol) name))
-  (defun signal (&rest args)
-    (%funcall (@ (guile) throw) 'elisp-error args)))
+  (defun signal (error-symbol data)
+    (%funcall (@ (guile) throw) 'elisp-condition error-symbol data)))
 
 (defmacro lambda (&rest cdr)
   `#'(lambda ,@cdr))
@@ -125,24 +125,6 @@
                    nil)))
        (,loop))))
 
-(defmacro catch (tag &rest body)
-  (let* ((temp (make-symbol "catch-temp"))
-         (elisp-key (make-symbol "catch-elisp-key"))
-         (key (make-symbol "catch-key"))
-         (value (make-symbol "catch-value")))
-    `(let ((,temp ,tag))
-       (declare (lexical ,temp))
-       (funcall (@ (guile) catch)
-                'elisp-exception
-                #'(lambda () ,@body)
-                #'(lambda (,key ,elisp-key ,value)
-                    (if (eq ,elisp-key ,temp)
-                        ,value
-                      (funcall (@ (guile) throw)
-                               ,key
-                               ,elisp-key
-                               ,value)))))))
-
 (defmacro unwind-protect (bodyform &rest unwindforms)
   `(funcall (@ (guile) dynamic-wind)
             #'(lambda () nil)
@@ -202,9 +184,6 @@
                       definition)))
   definition)
 
-(defun throw (tag value)
-  (funcall (@ (guile) throw) 'elisp-exception tag value))
-
 (defun load (file)
   (funcall (@ (system base compile) compile-file)
            file
@@ -366,6 +345,24 @@
 (defun nth (n list)
   (car (nthcdr n list)))
 
+(defun %member (elt list test)
+  (cond
+   ((null list) nil)
+   ((consp list)
+    (if (funcall test elt (car list))
+        list
+      (%member elt (cdr list) test)))
+   (t (signal 'wrong-type-argument `(listp ,list)))))
+
+(defun member (elt list)
+  (%member elt list #'equal))
+
+(defun memql (elt list)
+  (%member elt list #'eql))
+
+(defun memq (elt list)
+  (%member elt list #'eq))
+
 ;;; Strings
 
 (defun string (&rest characters)
@@ -382,11 +379,13 @@
 ;;; Property lists
 
 (defun %plist-member (plist property test)
-  (catch 'loop
-    (while plist
-      (if (funcall test (car plist) property)
-          (throw 'loop (cdr plist))
-        (setq plist (cddr plist))))))
+  (cond
+   ((null plist) nil)
+   ((consp plist)
+    (if (funcall test (car plist) property)
+        (cdr plist)
+      (%plist-member (cdr (cdr plist)) property test)))
+   (t (signal 'wrong-type-argument `(listp ,plist)))))
 
 (defun %plist-get (plist property test)
   (car (%plist-member plist property test)))
@@ -425,3 +424,72 @@
 
 (defun put (symbol propname value)
   (setplist symbol (plist-put (symbol-plist symbol) propname value)))
+
+;;; Nonlocal exits
+
+(defmacro condition-case (var bodyform &rest handlers)
+  (let ((key (make-symbol "key"))
+        (error-symbol (make-symbol "error-symbol"))
+        (data (make-symbol "data"))
+        (conditions (make-symbol "conditions")))
+    (flet ((handler->cond-clause (handler)
+             `((or ,@(mapcar #'(lambda (c) `(memq ',c ,conditions))
+                             (if (consp (car handler))
+                                 (car handler)
+                               (list (car handler)))))
+               ,@(cdr handler))))
+      `(funcall (@ (guile) catch)
+                'elisp-condition
+                #'(lambda () ,bodyform)
+                #'(lambda (,key ,error-symbol ,data)
+                    (declare (lexical ,key ,error-symbol ,data))
+                    (let ((,conditions
+                           (get ,error-symbol 'error-conditions))
+                          ,@(if var
+                                `((,var (cons ,error-symbol ,data)))
+                              '()))
+                      (declare (lexical ,conditions
+                                        ,@(if var `(,var) '())))
+                      (cond ,@(mapcar #'handler->cond-clause handlers)
+                            (t (signal ,error-symbol ,data)))))))))
+
+(put 'error 'error-conditions '(error))
+(put 'wrong-type-argument 'error-conditions '(wrong-type-argument error))
+(put 'invalid-function 'error-conditions '(invalid-function error))
+(put 'no-catch 'error-conditions '(no-catch error))
+(put 'throw 'error-conditions '(throw))
+
+(defvar %catch nil)
+
+(defmacro catch (tag &rest body)
+  (let ((tag-value (make-symbol "tag-value"))
+        (c (make-symbol "c"))
+        (data (make-symbol "data")))
+    `(let ((,tag-value ,tag))
+       (declare (lexical ,tag-value))
+       (condition-case ,c
+           (let ((%catch t))
+             ,@body)
+         (throw
+          (let ((,data (cdr ,c)))
+            (declare (lexical ,data))
+            (if (eq (car ,data) ,tag-value)
+                (car (cdr ,data))
+              (apply #'throw ,data))))))))
+
+(defun throw (tag value)
+  (signal (if %catch 'throw 'no-catch) (list tag value)))
+
+;;; I/O
+
+(defun princ (object)
+  (funcall (@ (guile) display) object))
+
+(defun print (object)
+  (funcall (@ (guile) write) object))
+
+(defun terpri ()
+  (funcall (@ (guile) newline)))
+
+(defun format* (stream string &rest args)
+  (apply (@ (guile) format) stream string args))