summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--modules/language/python/compile.scm62
-rw-r--r--modules/language/python/def.scm13
-rw-r--r--modules/language/python/exceptions.scm3
-rw-r--r--modules/language/python/guilemod.scm6
-rw-r--r--modules/language/python/module/itertools.scm7
-rw-r--r--modules/language/python/module/os/path.scm3
6 files changed, 44 insertions, 50 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index ad341a5..a039ee1 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -401,20 +401,20 @@
(define (fastfkn x) (hash-ref fasthash x))
(define (get-kwarg vs arg)
- (let lp ((arg arg) (l '()) (kw '()))
+ (let lp ((arg arg))
(match arg
+ (((#:comp . (and x (_ (#:cfor . _) . _))) . arg2)
+ (cons `(* ,(exp vs `(#:tuple ,@x))) (lp arg2)))
+ (((#:* a) . arg)
+ (cons `(* ,(exp vs a)) (lp arg)))
+ (((#:** a) . arg)
+ (cons `(** ,(exp vs a)) (lp arg)))
(((#:= a b) . arg)
- (lp arg
- l
- (cons*
- (exp vs b)
- (symbol->keyword
- (exp vs a))
- kw)))
+ (cons `(= ,(exp vs a) ,(exp vs b)) (lp arg)))
((x . arg)
- (lp arg (cons (exp vs x) l) kw))
+ (cons (exp vs x) (lp arg)))
(()
- (values (reverse l) (reverse kw))))))
+ '()))))
(define (get-args_ vs arg)
(let lp ((arg arg))
@@ -512,18 +512,8 @@
`(#:fast-id ,it ',tag)
`(#:identifier ',tag))))))
- ((#:arglist args apply kw)
- (call-with-values (lambda () (get-kwarg vs args))
- (lambda (args kwarg)
- (if (or kw apply)
- `(#:apply ,@args ,@kwarg
- ,`(,(L 'to-list)
- (,(G 'append)
- (if apply (exp vs apply) ''())
- (if kw
- '(,(C 'kw->li) (exp vs kw))
- ''()))))
- `(#:call ,@args ,@kwarg)))))
+ ((#:arglist args)
+ `(#:apply ,@(get-kwarg vs args)))
((#:subscripts (n #f #f))
`(#:vecref ,(exp vs n)))
@@ -723,20 +713,13 @@
(#:bytes
((_ l)
- (let* ((n (let lp ((l l) (s 0))
- (if (pair? l)
- (lp (cdr l) (+ s (length (car l))))
- s)))
- (b (make-bytevector n)))
+ (let* ((b (make-bytevector (length l))))
(let lp ((l l) (i 0))
(if (pair? l)
- (let lp2 ((u (car l)) (i i))
- (if (pair? u)
- (begin
- (bytevector-u8-set! b i (car u))
- (lp2 (cdr u) (+ i 1)))
- (lp (cdr l) i)))))
- `(,(B 'bytes) ,b))))
+ (begin
+ (bytevector-u8-set! b i (car l))
+ (lp (cdr l) (+ i 1)))
+ `(,(B 'bytes) ,b))))))
(#:+
@@ -1273,7 +1256,12 @@
(#:assign (l)))
(let ((s (string->symbol v)))
`(,s/d ,s ,(exp vs l)))))
-
+
+ (#:assert
+ ((_ x f n m)
+ `(if (,(G 'not) (,(G 'and) ,@(map (lambda (x) `(,(C 'boolit) ,(exp vs x)))
+ x)))
+ (,(C 'raise) ,(C 'AssertionError) ',f ,n ,m))))
(#:return
((_ x)
@@ -1832,9 +1820,9 @@
((_ v (#:call x ...) . l)
(ref-x (v x ...) . l))
((_ v (#:apply x ...) . l)
- (ref-x (apply v x ...) . l))
+ (ref-x (py-apply v x ...) . l))
((_ v (#:apply x ...) . l)
- (ref-x (apply v x ...) . l))
+ (ref-x (py-apply v x ...) . l))
((_ v (#:vecref x) . l)
(ref-x (pylist-ref v x) . l))
((_ v (#:vecsub . x) . l)
diff --git a/modules/language/python/def.scm b/modules/language/python/def.scm
index bd2139e..06e83e6 100644
--- a/modules/language/python/def.scm
+++ b/modules/language/python/def.scm
@@ -108,9 +108,10 @@
(define (no x)
(and-map
(lambda (x)
- (syntax-case x (* **)
- ((* _) #f)
- ((** _) #f)
+ (syntax-case x (* ** =)
+ ((* _) #f)
+ ((** _) #f)
+ ((= a b) #f)
(_ #t)))
x))
@@ -123,7 +124,9 @@
x))))
(define-syntax m*
- (syntax-rules (* **)
+ (syntax-rules (* ** =)
+ ((_ (= a b))
+ (list (symbol->keyword 'a) b))
((_ (* a)) a)
((_ (** kw))
(for ((k v : kw)) ((l '()))
@@ -137,7 +140,7 @@
(syntax-case x ()
((_ f a ...)
(if (no #'(a ...))
- #'(apply f a ...)
+ #'(f a ...)
#'(apply f (let lp ((l (list (m* a) ...)))
(if (pair? l)
(append (car l) (lp (cdr l)))
diff --git a/modules/language/python/exceptions.scm b/modules/language/python/exceptions.scm
index b12f89b..60b850e 100644
--- a/modules/language/python/exceptions.scm
+++ b/modules/language/python/exceptions.scm
@@ -7,7 +7,7 @@
SyntaxError SystemException
OSError ProcessLookupError PermissionError
None NotImplemented NotImplementedError
- RunTimeError))
+ RunTimeError AssertionError))
(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
@@ -27,6 +27,7 @@
(define PermissionError 'PermissionError)
(define NotImplementedError 'NotImplementedError)
(define RunTimeError 'RunTimeError)
+(define AssertionError 'AssertionError)
(define-python-class Exception ()
(define __init__
diff --git a/modules/language/python/guilemod.scm b/modules/language/python/guilemod.scm
index 3f7ec7f..da1f5c7 100644
--- a/modules/language/python/guilemod.scm
+++ b/modules/language/python/guilemod.scm
@@ -27,6 +27,7 @@
(define-exp-C *do-extension-dispatch* #t)
(define-exp-C *extension-dispatches* '((("py" "python") . python)
(("pl" "prolog") . prolog)))
+(define-exp-C %current-file% (make-fluid '(guile)))
(define-C default-language
(lambda (file)
@@ -57,9 +58,12 @@
(env ((C default-environment) from))
(opts '())
(canonicalization 'relative))
+
(with-fluids (((C %in-compile ) #t )
((M %dont-warn-list ) '() )
- ((C %file-port-name-canonicalization) canonicalization))
+ ((C %file-port-name-canonicalization) canonicalization )
+ ((C %current-file% ) file))
+
(let* ((comp (or output-file ((C compiled-file-name) file)
(error "failed to create path for auto-compiled file"
file)))
diff --git a/modules/language/python/module/itertools.scm b/modules/language/python/module/itertools.scm
index c4958d1..b5b3dbf 100644
--- a/modules/language/python/module/itertools.scm
+++ b/modules/language/python/module/itertools.scm
@@ -149,17 +149,18 @@
(lambda (yield)
(let lp ((head #f))
(if (and head (= i head))
- (let* ((x (next it))
+ (let* ((x (call-with-values (lambda () (next it))
+ (lambda x x)))
(i0 (+ i 1)))
(set! r (cons x r))
(set! i i0)
- (yield x)
+ (apply yield x)
(lp i0))
(if (pair? l)
(let ((x (car l)))
(set! l (cdr l))
- (yield x)
+ (apply yield x)
(lp #f))
(if (null? r)
(lp i)
diff --git a/modules/language/python/module/os/path.scm b/modules/language/python/module/os/path.scm
index 8d76762..0c1abde 100644
--- a/modules/language/python/module/os/path.scm
+++ b/modules/language/python/module/os/path.scm
@@ -175,9 +175,6 @@
(define (isdir p)
(ca (S_ISDIR (stat:mode ((@ (guile) stat) (path-it p))))))
-(define (islink p)
- (ca (S_ISLNK (stat:mode ((@ (guile) stat) (path-it p))))))
-
(define (ismount p)
(ca
(let* ((p (path-it p))
generated by cgit v1.2.3 (git 2.46.0) at 2024-09-20 11:22:16 +0000