bugfixes
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Sat, 16 Sep 2017 13:13:18 +0000 (15:13 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Sat, 16 Sep 2017 13:13:18 +0000 (15:13 +0200)
modules/language/python/exceptions.scm
modules/language/python/try.scm
modules/language/python/yield.scm
modules/oop/pf-objects.scm

index 1bbec08179c79e329b953f65edafc1cfff975835..954f3b34d5d61c9508537b145dc23b8bd804d64a 100644 (file)
@@ -15,7 +15,7 @@
     (case-lambda
       ((self)
        (values))
-      ((self str)
+      ((self str . l)
        (set self 'str str))))
                  
   (define __repr__
index 4467a78c362e6c09aa625c3aeae659156656c23f..448c841d45a7d2b7caafd7a1e95f7afdb2d90b8e 100644 (file)
@@ -9,13 +9,23 @@
 
 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
 
-(define-method (check (class <class> ) obj l) (is-a? obj class))
-(define-method (check (s     <symbol>) obj l) (eq? obj s))
-(define-method (check (p  <procedure>) obj l)
-  (aif it (procedure-property p 'pyclass)
-       (is-a? obj it)
-       (p obj l)))
-  
+(define-inlinable (standard-check class obj l)
+  (if (struct? obj)
+      (if (is-a? obj <p>)
+          (if (is-a? class <p>)
+              (is-a? obj (ref class '__goops__))
+              (is-a? obj class))
+          (if (is-a? obj <object>)
+              (is-a? obj class)
+              (eq? obj class)))
+      (if (and (procedure? class) (not (pyclass? class)))
+          (apply class obj l)
+          (eq? class obj))))
+          
+      
+(define (check class obj l)
+  (standard-check class obj l))
+
 (define-syntax compile-error
   (lambda (x)
     (syntax-case x ()
 
 (define-syntax handler
   (syntax-rules (=>)
+
     ((handler ecx)
-     (lambda x
-       (match x
-         ((_ 'python tag . l)
-          (handler ecx tag l))
-         ((k . x)
-          (apply throw x)))))
+     (lambda (k tag . l)
+       (handler ecx tag l)))
     
     ((handler ((#:except E => lam) . ecx) tag l)
      (if (check-exception E tag l)
@@ -50,7 +57,7 @@
 
     ((handler ((#:except E code ...) . ecx) tag l)
      (if (check-exception E tag l)
-         (begin code ...)
+         (nbegin code ...)
          (handler ecx tag l)))
 
     ((handler ((#:else code ...)) tag l)
        (lambda () #f)
        (lambda ()
          (catch #t
-           (lambda () code)
+           code
            (handler (exc ...))))
        (lambda ()
          (if (not (fluid-ref in-yield))
-             fin))))
+             (fin)))))
 
     ((try  code exc ...)
      (catch #t
-       (lambda () code)
+       code
        (handler (exc ...))))))
   
 
 (define raise
   (case-lambda
     (() (raise Exception))
-    ((x)
-     (if (procedure? x)
-         (if (procedure-property x 'pyclass)
-             (throw 'python (x))
-             (throw 'python x))
-         (throw 'python x)))))
+    ((x . l)
+     (if (pyclass? x)
+         (throw 'python (apply x l))
+         (apply throw 'python x l)))))
index 95397c70e88d5ba0a9e92460f5b0403da8fc52a0..569775d2b327faf01e2461c416ded73a43d47339 100644 (file)
       ((_ x ...)
        #'(begin
            (fluid-set! in-yield #t)
-           (abort-to-prompt YIELD x ...)))
+           ((abort-to-prompt YIELD x ...))))
       (x
        #'(lambda x
            (fluid-set! in-yield #t)
-           (apply abort-to-prompt YIELD x))))))
+           ((apply abort-to-prompt YIELD x)))))))
 
 (define (make-generator closure)
   (lambda args
         (s (slot-ref l 's))
         (c (slot-ref l 'closed)))
     (if (not c)
-        (if k
-            (k (lambda () (throw 'python (apply e ls))))
+        (if k           
+            (k (lambda ()
+                 (if (pyclass? e) 
+                     (throw 'python (apply e ls))
+                     (apply throw 'python e ls))))
             (throw 'python (Exception))))))
 
 (define-method (sendClose (l <yield>))
index 75304dba5219e22f7d415889683d40ef4832c11a..323abfdcb81017329a80d8e2ae5c489ebccb8aa0 100644 (file)
@@ -4,7 +4,7 @@
   #:use-module (ice-9 match)
   #:export (set ref make-pf <p> <py> <pf> <pyf>
                 call with copy fset fcall make-p put put!
-                pcall pcall! get fset-x
+                pcall pcall! get fset-x pyclass?
                 def-pf-class  mk-pf-class  make-pf-class
                 def-p-class   mk-p-class   make-p-class
                 def-pyf-class mk-pyf-class make-pyf-class
@@ -656,4 +656,4 @@ explicitly tell it to not update etc.
                  ())))
 
 (define (pyclass? x)
-  (and (is-a? x <p>) (not (ref x '__class__))))
+   (and (is-a? x <p>) (not (ref x '__class__))))