--- /dev/null
+(define-module (language python bool)
+ #:use-module (oop goops)
+ #:use-module (oop pf-objects)
+ #:export (bool))
+
+(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
+
+(define-method (bool x)
+ (cond
+ ((null? x)
+ #f)
+ (else x)))
+
+(define-method (bool (x <integer>)) (not (= x 0)))
+(define-method (bool (x <p>))
+ (aif it (ref x '__bool__)
+ (it)
+ (next-method)))
+
+
#:use-module (language python exceptions)
#:use-module (language python list)
#:use-module (language python hash)
+ #:use-module (language python bool)
#:use-module (language python persist)
#:export (<py-bytes> pybytes-listing bytes bytearray bytes->bytevector
<py-bytearray> pybytesarray-listing))
(n (slot-ref o 'n)))
(apply g bytearray b n l)))))
+(define-py* -bool (bool m o nn) (not (= (len o) 0)))
+
(define-method (write (b <py-bytes>) . l)
(define port (if (pair? l) (car l) #t))
(format port "b'")
(ww- (fold get-ww '() #'(arg ...)))
(kv (fold get-kv '() #'(arg ...))))
(if (and-map null? (list kw ww- kv))
- #`(lambda #,as code ...)
+ #`(object-method (lambda #,as code ...))
(with-syntax ((kw (if (null? kw)
(datum->syntax x (gensym "kw"))
(car kw)))
((k ...) (map car kv))
((s ...) (map ->kw (map car kv)))
((v ...) (map cdr kv)))
- #`(object-method
- (lambda* (#,@as . l)
- (call-with-values (lambda () (get-akw l))
- (lambda (ww* kw)
- (let*-values (((ww* k) (take-1 #,(null? ww-) ww* kw s v))
+ #`(object-method
+ (lambda* (#,@as . l)
+ (call-with-values (lambda () (get-akw l))
+ (lambda (ww* kw)
+ (let*-values (((ww* k) (take-1 #,(null? ww-) ww* kw s v))
...)
- (let ((ww ww*)
- (kw (pytonize kw)))
- code ...)))))))))))))
+ (let ((ww ww*)
+ (kw (pytonize kw)))
+ code ...)))))))))))))
(define-syntax-rule (def (f . args) code ...) (define f (lam args code ...)))
#:use-module (language python yield)
#:use-module (language python def)
#:use-module (language python for)
+ #:use-module (language python bool)
#:use-module (language python exceptions)
#:use-module (language python persist)
#:use-module (ice-9 match)
py-popitem py-setdefault py-update py-clear
py-hash-ref dict pyhash-listing
weak-key-dict weak-value-dict
+ py-hash-ref py-hash-set!
))
(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
(next-method)))))))
+(define-method (bool (o <hashtable>))
+ (for ((k v : o)) ()
+ (break #t)
+ #:final #f))
+
+(define-method (bool (o <py-hashtable>))
+ (not (= (len o) 0)))
(define-py (py-copy copy o)
(<hashtable>
#:use-module (language python yield)
#:use-module (language python for)
#:use-module (language python try)
+ #:use-module (language python bool)
#:use-module (language python exceptions)
#:use-module (language python persist)
#:export (to-list to-pylist <py-list> py-list
(define-method (to-pylist (o <string>))
(to-pylist (string->list o)))
+(define-method (bool (o <py-list>))
+ (not (= (len o) 0)))
+(define-method (bool (o <vector>))
+ (not (= (len o) 0)))
+(define-method (bool (o <string>))
+ (not (= (len o) 0)))
+
(define-method (to-pylist l)
(if (null? l)
(let ((o (make <py-list>)))
(let ((seen (py-set)))
(if (string? field_names)
(set! field_names (string-split field_names #\,)))
-
+
(set! field_names (py-list (py-map scm-str field_names)))
(set! typename (scm-str typename))
-
+
(if rename
(for ((index name : (enumerate field_names))) ()
(if (or (not (py-identifier? name))
(raise ValueError
(+ "Type names and field names cannot be a "
(format #f "keyword: ~a" name)))))
-
+
(set! seen (py-set))
(for ((name : field_names)) ()
(if (and (py-startswith name "_") (not rename))
field_names)))
mod))
- (pylist-set! dict '__getitem__
- (lambda (self i)
+ (pylist-set! dict '__getitem__
+ (lam (self i)
(if (number? i)
(ref self (list-ref field_names i))
(ref self (scm-sym i)))))
(pylist-set! dict '__setitem__
- (lambda (self i val)
+ (lam (self i val)
(if (number? i)
(set self (list-ref field_names i) val)
(set self (scm-sym i) val))))
(pylist-set! dict '__repr__
- (lambda (self)
+ (lam (self)
(let ((l (map (lambda (x)
(format #f "~a=~a"
x
(map scm-sym
(string-split module #\.))))))
- (pylist-set! dict '__module__ module)
-
(if verbose (pretty-print verbose))))))
(define UserDict dict)
(define __mul__
(lambda (self n)
- (let ((o (dequeue)))
+ (let ((o (deque)))
(let ((f (ref o 'append)))
(let lp ((i 0))
(if (< i n)
(define-module (language python module functools)
+ #:use-module (ice-9 control)
#:use-module (oop pf-objects)
#:use-module (language python for)
#:use-module (language python try)
#:use-module (language python def)
#:use-module (language python module threading)
#:use-module (language python module weakref)
+ #:use-module (language python module collections)
+ #:use-module ((language python module python)
+ #:select (iter getattr setattr repr isinstance callable
+ bool str int))
+ #:use-module (language python list)
+ #:use-module (language python dict)
+ #:use-module (language python set)
+ #:use-module (language python tuple)
+ #:use-module (language python property)
+ #:use-module (language python exceptions)
#:export (WRAPPER_ASSIGNMENTS WRAPPER_UPDATES
update_wrapper wraps total_ordering
cmp_to_key partial partialmethod lru_cache
reduce singledispatch))
-
+(define-syntax aif
+ (syntax-rules ()
+ ((_ it p x ) (aif it p x (values)))
+ ((_ it p x y) (let ((it p)) (if it x y)))))
(def (reduce f it (= initializer None))
(let ((it (iter it))
(for ((attr : assigned)) ()
(try
(lambda ()
- (let ((value (getatt wrapped attr)))
+ (let ((value (getattr wrapped attr)))
(setattr wrapper attr value)))
(#:except AttributeError => values)))
(for ((attr : updated)) ()
- (py-uppdate (getattr wrapper attr) (getattr wrapped attr (dict))))
+ (py-update (getattr wrapper attr) (getattr wrapped attr (dict))))
(set wrapper '__wrapped__ wrapped)
cls)))
-
-def cmp_to_key(mycmp):
- """Convert a cmp= function into a key= function"""
- class K(object):
- __slots__ = ['obj']
- def __init__(self, obj):
- self.obj = obj
- def __lt__(self, other):
- return mycmp(self.obj, other.obj) < 0
- def __gt__(self, other):
- return mycmp(self.obj, other.obj) > 0
- def __eq__(self, other):
- return mycmp(self.obj, other.obj) == 0
- def __le__(self, other):
- return mycmp(self.obj, other.obj) <= 0
- def __ge__(self, other):
- return mycmp(self.obj, other.obj) >= 0
- __hash__ = None
- return K
(define (cmp_to_key mycmp)
- (define-python-class-unamed K
+ (define-python-class-noname K ()
(define __init__
- (lambda (self, obj)
+ (lambda (self obj)
(set self 'obj obj)))
(define __lt__
- (lambda (self, other)
- (< (mycmp (ref self 'obj) (ref other obj)) 0)))
+ (lambda (self other)
+ (< (mycmp (ref self 'obj) (ref other 'obj)) 0)))
(define __gt__
- (lambda (self, other)
- (> (mycmp (ref self 'obj) (ref other obj)) 0)))
+ (lambda (self other)
+ (> (mycmp (ref self 'obj) (ref other 'obj)) 0)))
(define __eq__
- (lambda (self, other)
- (= (mycmp (ref self 'obj) (ref other obj)) 0)))
+ (lambda (self other)
+ (= (mycmp (ref self 'obj) (ref other 'obj)) 0)))
- (define __lt__
- (lambda (self, other)
- (<= (mycmp (ref self 'obj) (ref other obj)) 0)))
+ (define __le__
+ (lambda (self other)
+ (<= (mycmp (ref self 'obj) (ref other 'obj)) 0)))
- (define __gt__
- (lambda (self, other)
- (>= (mycmp (ref self 'obj) (ref other obj)) 0))))
+ (define __ge__
+ (lambda (self other)
+ (>= (mycmp (ref self 'obj) (ref other 'obj)) 0))))
K)
(raise TypeError "the first argument must be callable"))
(aif it (ref func 'func)
- (begin
- (set! args (+ (ref func 'args) args))
- (let ((tmpkw (py-copy (ref func 'keywords))))
- (py-update mpkw keywords)
- (set! keywords tmpkw)
- (set func it))))
+ (begin
+ (set! args (+ (ref func 'args) args))
+ (let ((tmpkw (py-copy (ref func 'keywords))))
+ (py-update tmpkw keywords)
+ (set! keywords tmpkw)
+ (set func it))))
(set self 'func func )
(set self 'args args )
(lam (self (* args) (** keywords))
(let ((newkeywords (py-copy (ref self 'keywords))))
(py-update newkeywords 'keywords)
- (py-apply (ref self 'func) (* (ref self 'args) (* args)
- (** newkeywords))))))
+ (py-apply (ref self 'func) (* (ref self 'args)) (* args)
+ (** newkeywords)))))
(define __repr__
(lambda (self)
(def (_method self (* args) (** keywords))
(let ((call_keywords (py-copy (ref self 'keywords)))
- (call_args (+ (cls_or_self) (ref self 'args) args)))
+ (call_args (+ (list self) (ref self 'args) args)))
(py-update call_keywords keywords)
(py-apply (ref self 'func) (* call_args) (** call_keywords))))
(* (ref self 'args ))
(** (ref self 'keywords))))
(aif it (ref new_func '__self__)
- (set! result '__self__ it))))))
+ (set result '__self__ it))))))
(if (not result)
((ref ((ref self '_make_unbound_method)) '__get__) obj cls)
result))))
(define _CacheInfo (namedtuple "CacheInfo"
- '("hits", "misses", "maxsize", "currsize")))
+ '("hits" "misses" "maxsize" "currsize")))
(define-python-class _HashedSeq (py-list)
(define __init__
(define __hash__
(lambda (self)
- (ref self 'hashvalue)))
+ (ref self 'hashvalue))))
(def (_make_key args kwds typed
(= kwd_mark (list (object)))
(begin
(set! key
(+ key
- (for ((a : args)) (l '())
+ (for ((a : args)) ((l '()))
(cons (type a) l)
#:final (reverse l))))
(if (bool kwds)
user_function maxsize typed _CacheInfo)))
(update_wrapper wrapper user_function))))
+(define <dict> `(,<py-hashtable> . _))
+
(define (_lru_cache_wrapper user_function maxsize typed _CacheInfo)
(define sentinel (object))
(define make_key _make_key)
(define cache (dict))
(define-values (hits misses) (values 0 0))
(define full #f)
- (define cache_get cache.get)
- (define cache_len cache.__len__)
+ (define cache_get (resolve-method-g py-get <dict>))
+ (define cache_len (resolve-method-g len <dict>))
(define lock (RLock))
(define root (list 0 0 0 0))
(list-set! root 0 root)
(list-set! root 1 root)
- (list-set! root 2 none)
- (list-set! root 3 none)
+ (list-set! root 2 None)
+ (list-set! root 3 None)
(let ((wrapper
(cond
(oldresult (list-ref root RESULT)))
(list-set! root KEY None)
(list-set! root RESULT None)
- (pylist-delte! cache oldkey)
+ (pylist-delete! cache oldkey)
(pylist-set! cache key oldroot))))
(else
- (let ((last (list-ref root PREV))
- (link (list last root key result)))
+ (let* ((last (list-ref root PREV))
+ (link (list last root key result)))
(list-set! last NEXT link)
(list-set! root PREV link)
(pylist-set! cache key link)
(define (cache_clear)
(with lock
- (pylist-clear! cache)
+ (py-clear cache)
(set! root (list #f #f None None))
(list-set! root 0 root)
(list-set! root 1 root)
(set! misses 0)
(set! full #f)))
- (set wrapper 'cache_info cache_info)
- (set! wrapper 'cache_clear cache_clear)
+ (set wrapper 'cache_info cache_info)
+ (set wrapper 'cache_clear cache_clear)
wrapper))
+#|
;; single dispatch
(define (_c3_merge sequences)
(let lp ((result '()))
(update_wrapper wrapper func)
wrapper)
+|#
#:use-module (language python range )
#:use-module (language python tuple )
#:use-module (language python eval )
+ #:use-module (language python bool )
#:replace (list abs min max hash round format)
IndexError KeyError AttributeError
send sendException next
GeneratorExit sendClose RuntimeError
- SyntaxError
+ SyntaxError bool
len dir next dict None property range
tuple bytes bytearray eval locals globals
compile exec type object
set all any bin callable reversed
chr classmethod staticmethod
divmod enumerate filter open
- getattr hasattr hex isinstance issubclass
+ getattr hasattr setattr hex isinstance issubclass
iter map sum id input oct ord pow super
sorted zip))
(define miss ((@ (guile) list) 'miss))
(define* (getattr a b #:optional (k miss))
- (let ((r (ref a (symbol->string b) k)))
+ (let ((r (ref a (if (string? b) (string->symbol b) b) k)))
(if (eq? r miss)
(raise AttributeError "object/class ~a is missing attribute ~a" a b)
r)))
+(define (setattr a k v)
+ (set a (if (string? k) (string->symbol k) k) v))
+
(define (hasattr a b)
(let ((r (ref a (symbol->string b) miss)))
(not (eq? r miss))))
(setvbuf port 'block buffering)))
port))
-
-
-
#:use-module (language python def)
#:export (RLock))
-(define-python-class RLock
+(define-python-class RLock ()
(define __init__
(lambda (self)
(set self '_lock (make-mutex 'recursive))))
-
+
(define __enter__
(lambda (self)
(lock-mutex (ref self '_lock))))
(lambda (self)
(unlock-mutex (ref self '_lock))))
-
(define acquire
- (lam (self (= blocking #t) (timeout -1))
+ (lam (self (= blocking #t) (= timeout -1))
(if blocking
(if (< timeout 0)
(lock-mutex (ref self '_lock))
(s (floor y))
(us (floor (* (- y s) 1000000))))
(lock-mutex (ref self '_lock) (cons s us))))
- (try-lock (ref self '_lock)))))
-
+ (try-mutex (ref self '_lock)))))
+
(define release __leave__))
(cons (cons k v) l)
#:final
(reverse l))))
- ((member tag fixed)
- (raise KeyError (format #f "key ~a is unmutable" tag)))
(else
(set-procedure-property! f tag val))))
(pylist-sort! ret)
ret))
-(define (mk-getter-object f)
- (lambda (obj cls)
- (if (eq? obj cls)
- (lambda x (apply f x))
- (lambda x (apply f obj x)))))
(define-python-class property (<property>)
(define __init__
(lam (o (= getx None) (= setx None) (= delx None))
- (slot-set! o 'get getx)
- (slot-set! o 'set setx)
- (slot-set! o 'del delx)
- o))
-
+ (slot-set! o 'get getx)
+ (slot-set! o 'set setx)
+ (slot-set! o 'del delx)
+ o))
+
+ (define __get__
+ (lambda (obj class)
+ (if (eq? obj class)
+ obj
+ ((slot-ref obj 'get) obj))))
+
(define setter
(lambda (self f)
(slot-set! self 'set f)
#:use-module (language python list)
#:use-module (language python yield)
#:use-module (language python persist)
- #:export (py-set))
+ #:use-module (language python bool)
+ #:export (py-set frozenset))
(define-class <set> () dict)
(name-object <set>)
(let lp ((a a))
(if (pair? a)
(begin
- (h-set! h (caar a) (cdar a))
+ (py-hash-set! h (caar a) (cdar a))
(lp (cdr a))))))))
(list
(hash-fold (lambda (k v s) (cons (cons k v) s))
(slot-set! self 'dict d)
(if (eq? x '())
(values)
- (for ((y : x)) ()
- (pylist-set! d y #t)))))))
+ (for ((y : x)) ()
+ (pylist-set! d y #t)))))))
+ (define __bool__
+ (lambda (self)
+ (bool (slot-ref self 'dict))))
+
(define pop
(lambda (self)
(call-with-values (lambda () (pylist-pop! (slot-ref self 'dict)))
(yield k)
(values))))))
-(name-object set)
-
(define py-set set)
+(define-python-class frozenset (set))
#:use-module (language python list)
#:use-module (language python exceptions)
#:use-module (language python for)
+ #:use-module (language python bool)
#:use-module (language python persist)
#:export (py-format py-capitalize py-center py-endswith
py-expandtabs py-find py-rfind
(define-py0 (pylist-ref s i)
(list->string (list (string-ref s i))))
+(define-py0 (bool s)
+ (not (= (len s) 0)))
+
(define-py (py-capitalize capitalize s)
(let* ((n (len s))
(w (make-string n)))
#:use-module (oop pf-objects)
#:use-module (language python hash)
#:use-module (language python for)
+ #:use-module (language python bool)
#:use-module (language python persist)
#:export (tuple <py-tuple> defpair))
(define-method (py-class (o <py-tuple>) tuple))
(define-method (py-equal? (o1 <py-tuple>) o2) (equal? (slot-ref o1 'l) o2))
(define-method (py-equal? o1 (o2 <py-tuple>)) (equal? o1 (slot-ref o2 'l)))
+(define-method (bool (o <py-tuple>)) (pair? (slot-ref o 'l)))
(define-method (wrap-in (o <py-tuple>))
(wrap-in (slot-ref o 'l)))
(lambda x (apply f cls x))))
(define (class-method f)
- (set f '__get__ (mk-getter-class f)))
+ (set f '__get__ (mk-getter-class f))
+ f)
(define (object-method f)
- (set f '__get__ (mk-getter-object f)))
+ (set f '__get__ (mk-getter-object f))
+ f)
(define (static-method f)
- (set f '__get__ #f))
+ (set f '__get__ #f)
+ f)
(define (resolve-method-g g pattern)
(define (type- meta name parents dict keys)
(let ((class (new-class meta name parents dict keys)))
- (aif it (ref meta '__init__)
- (it name parents dict keys)
+ (aif it (and meta (find-in-class meta '__init__ #f))
+ (it class name parents dict keys)
#f)
class))
(let ((dict (gen-methods (get-dict meta name keys))))
(aif it (ref meta '__class__)
(aif it (find-in-class (ref meta '__class__) '__call__ #f)
- (apply (it meta 'class) name parents dict keys)
+ (apply it meta name parents dict keys)
(type- meta name parents dict keys))
(type- meta name parents dict keys))))
(define (create-object class meta goops x)
(with-fluids ((*make-class* #t))
- (aif it #f ;(ref meta '__call__)
+ (aif it #f
(apply it x)
(let ((obj (aif it (find-in-class class '__new__ #f)
- ((it class 'object))
- (make-object class meta goops))))
+ (it)
+ (make-object class meta goops))))
(aif it (ref obj '__init__)
(apply it x)
#f)
(define-inlinable (gox obj it)
(let ((class (fluid-ref *location*)))
- (aif it (rawref it '__get__)
- (it obj class)
+ (aif f (rawref it '__get__)
+ (f obj class)
it)))
(define *location* (make-fluid #f))
(define not-implemented (cons 'not 'implemeneted))
-(define-syntax-rule (prop-ref xx x)
- (let ((y xx)
- (r x))
- (if (and (is-a? r <property>) (not (pyclass? y)))
- ((slot-ref r 'get) y)
- r)))
-
(define-syntax-rule (mrefx-py x key l)
(let ((xx x))
- (prop-ref
- xx
(let* ((g (mrefx xx '__fget__ '(#t)))
(f (if g
(if (eq? g #t)
(gox xx (mrefx xx key l))
(catch #t
(lambda ()
- (f key))
+ (gox xx (f key)))
(lambda x
- (gox xx (mrefx xx key l)))))))))
+ (gox xx (mrefx xx key l))))))))
(define-syntax-rule (mref x key l)
(define-syntax-rule (mset-py x key val)
(let* ((xx x)
(v (mref xx key (list fail))))
- (if (or (eq? v fail)
- (not (and (is-a? v <property>)
- (not (pyclass? xx)))))
+ (if (eq? v fail)
(let* ((g (mrefx xx '__fset__ '(#t)))
(f (if g
(if (eq? g #t)
(catch #t
(lambda () (f key val))
(lambda q (mset xx key val)))))
- ((slot-ref v 'set) xx val))))
+
+ (aif it (ref v '__class__)
+ (aif it (ref it '__set__)
+ (it val)
+ (mset xx key val))
+ (mset xx key val)))))
(define-syntax-rule (mklam (mset a ...) val)
(mset a ... val))
<pyf>
<py>)
(defaulter default))))))
-
+(define type #f)
(define object #f)
(define (make-p-class name supers.kw methods)
(define kw (cdr supers.kw))
type
(let* ((p (car parents))
(m (ref p '__class__))
- (mro (reverse (ref m '__mro__))))
+ (mro (reverse (ref m '__mro__ '()))))
(let lp ((l (cdr parents))
(max mro)
(min mro))
(if (pair? l)
(let* ((p (car l))
(meta (ref p '__class__))
- (mro (ref meta '__mro__)))
+ (mro (ref meta '__mro__ '())))
(let lp2 ((max max) (mr (reverse mro)))
(if (and (pair? max) (pair? mr))
(if (eq? (car max) (car mr))
(define goops (make-class (append goopses (list (kw->class kw meta)))
'() #:name name))
-
+
+ (define (make-module)
+ (let ((l (module-name (current-module))))
+ (if (and (>= (length l) 3)
+ (equal? (list-ref l 0) 'language)
+ (equal? (list-ref l 1) 'python)
+ (equal? (list-ref l 2) 'module))
+ (string-join
+ (map symbol->string (cdddr l))
+ ".")
+ l)))
+
(define (gen-methods dict)
(methods dict)
(pylist-set! dict '__goops__ goops)
(pylist-set! dict '__class__ meta)
+ (pylist-set! dict '__module__ (make-module))
+ (pylist-set! dict '__bases__ parents)
(pylist-set! dict '__fget__ #t)
(pylist-set! dict '__fset__ #t)
(pylist-set! dict '__name__ name)
- (pylist-set! dict '__parents__ parents)
(pylist-set! dict '__class__ meta)
(pylist-set! dict '__mro__ (get-mro parents))
dict)
;; Let's make an object essentially just move a reference
;; the make class and defclass syntactic sugar
+
+(define-syntax make-up
+ (syntax-rules (lambda case-lambda lambda* letrec letrec*)
+ ((_ (lambda . l))
+ (object-method (lambda . l)))
+ ((_ (case-lambda . l))
+ (object-method (case-lambda . l)))
+ ((_ (lambda* . l))
+ (object-method (lambda* . l)))
+ ((_ (letrec . l))
+ (object-method (letrec . l)))
+ ((_ (letrec* . l))
+ (object-method (letrec* . l)))
+ ((_ x) x)))
+
(define-syntax mk-p-class
(lambda (x)
(syntax-case x ()
(symbol->string
(syntax->datum #'name))
"-goops-class")))))
- (%add-to-warn-list (syntax->datum #'nname))
+ (%add-to-warn-list (syntax->datum #'nname))
(map (lambda (x) (%add-to-warn-list (syntax->datum x)))
#'(ddname ...))
#'(let ()
(define name
- (letruc ((dname dval) ...)
- (make-p-class 'name
+ (letruc ((dname (make-up dval)) ...)
+ (make-p-class 'name
parents
(lambda (dict)
(pylist-set! dict 'dname dname)
(define-syntax-rule (define-python-class name (parents ...) code ...)
(define name (mk-p-class name (arglist->pkw (list parents ...)) code ...)))
-(define-syntax-rule (define-pythonc-lass-noname name (parents ...) code ...)
+(define-syntax-rule (define-python-class-noname name (parents ...) code ...)
(define name (mk-p-class-noname name (arglist->pkw (list parents ...))
code ...)))
(up (car h) (cdr h))
#f)))))
-(define (class-to-tree cl) (cons cl (map class-to-tree (ref cl '__parents__))))
+(define (class-to-tree cl) (cons cl (map class-to-tree (ref cl '__bases__))))
(define (find-tree o tree)
(if tree
(define (equal? x y) (or (eq? x y) (py-equal? x y)))
-(define type #f)
(set! type
(make-python-class type ()
(define __call__
projects / software / python-on-guile.git / commitdiff
