From 6ae273a9f5a0bbc9c02627287c8b5f958fc2095f Mon Sep 17 00:00:00 2001 From: Stefan Israelsson Tampe Date: Thu, 16 Aug 2018 22:41:44 +0200 Subject: improvements of optparse --- modules/language/python/compile.scm | 117 +++++++++++++++++------------ modules/language/python/list.scm | 32 ++++---- modules/language/python/module.scm | 4 +- modules/language/python/module/_python.scm | 16 +++- modules/language/python/module/io.scm | 21 +++--- modules/language/python/module/optparse.py | 16 ++-- modules/language/python/module/os.scm | 21 +++++- modules/language/python/module/python.scm | 5 +- modules/language/python/module/sys.scm | 11 ++- 9 files changed, 153 insertions(+), 90 deletions(-) (limited to 'modules/language') diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index b2f5ea7..de4299d 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -43,6 +43,8 @@ (define-inlinable (H x) `(@ (language python hash) ,x)) (define-inlinable (W x) `(@ (language python with) ,x)) +(define cvalues (G 'values)) + (define-syntax-rule (wth code) (let ((old s/d)) (set! s/d (C 'qset!)) @@ -616,7 +618,7 @@ (_ (error "unhandled addings"))) (get-addings vs l fast?)))))) - + (define-syntax-rule (setwrap u) (call-with-values (lambda () u) (case-lambda @@ -760,7 +762,7 @@ (#:decorated ((_ (l ...)) (fluid-set! decorations (map (g vs exp) l)) - '(values))) + `(,cvalues))) (#:string ((_ l) @@ -1049,7 +1051,7 @@ (if (< ,x ,v) (begin (,(C 'let/ec) continue-ret - (,(C 'with-sp) ((continue (values)) + (,(C 'with-sp) ((continue (,cvalues)) (break (break-ret))) ,code2)) (,lp (+ ,x 1)))))))) @@ -1079,7 +1081,7 @@ (if (< ,x ,v2) (begin (,(C 'let/ec) continue-ret - (,(C 'with-sp) ((continue (values)) + (,(C 'with-sp) ((continue (,cvalues)) (break (break-ret))) ,code2)) (,lp (+ ,x 1))))))) @@ -1109,7 +1111,7 @@ (begin (,(C 'let/ec) continue-ret (,(C 'with-sp) - ((continue (values)) + ((continue (,cvalues)) (break (break-ret))) ,code2)) (,lp (+ ,x ,st))))) @@ -1119,7 +1121,7 @@ (begin (,(C 'let/ec) continue-ret (,(C 'with-sp) - ((continue (values)) + ((continue (,cvalues)) (break (break-ret))) ,code2)) (,lp (+ ,x ,st))))) @@ -1180,7 +1182,7 @@ (if (,(C 'boolit) ,(exp vs test)) (begin (,(C 'let/ec) continue-ret - (,(C 'with-sp) ((continue (values)) + (,(C 'with-sp) ((continue (,cvalues)) (break (break-ret))) ,code2)) (,lp))))) @@ -1203,7 +1205,7 @@ (if (,(C 'boolit) ,(exp vs test)) (begin (,(C 'let/ec) ,(C 'continue-ret) - (,(C 'with-sp) ((continue (values)) + (,(C 'with-sp) ((continue (,cvalues)) (break (break-ret))) ,code2)) (,lp)) @@ -1377,7 +1379,7 @@ (#:global ((_ . _) - '(values))) + `(,cvalues))) (#:list ((_ x (and e (#:cfor . _))) @@ -1429,7 +1431,7 @@ (#:stmt ((_ l) (if (> (length l) 1) - (cons 'values (map (g vs exp) l)) + (cons cvalues (map (g vs exp) l)) (exp vs (car l))))) (#:expr-stmt @@ -1460,12 +1462,12 @@ (if (= (length l) 1) `(begin ,(make-set vs op (car l) (exp vs (car u))) - (values)) + (,cvalues)) `(begin ,@(map (lambda (l u) (make-set vs op l u)) l (map (g vs exp) u)) - (values)))) + (,cvalues)))) ((and (= (length u) 1) (not op)) (let ((vars (map (lambda (x) (gensym "v")) l)) @@ -1483,12 +1485,12 @@ ,@(map (lambda (l v) (make-set vs op l v)) l vars))))) ,f)) - (values)))) + (,cvalues)))) ((and (= (length l) 1) (not op)) `(begin ,(make-set vs op (car l) `(,(G 'list) ,@(map (g vs exp) u))) - (values))))))) + (,cvalues))))))) ((_ ((#:test (#:power #f (#:identifier v . _) () . #f) #f)) @@ -1532,7 +1534,7 @@ ,@(map (lambda (l u) (make-set vs op l u)) l (map (g vs exp) u)) - (values ,@(map (g exp vs) l))))) + (,cvalues ,@(map (g exp vs) l))))) ((and (= (length u) 1) (not op)) (let ((vars (map (lambda (x) (gensym "v")) l)) @@ -1550,12 +1552,12 @@ ,@(map (lambda (l v) (make-set vs op l v)) l vars))))) ,f)) - (values ,@(map (g exp vs) l))))) + (,cvalues ,@(map (g exp vs) l))))) ((and (= (length l) 1) (not op)) `(begin ,(make-set vs op (car l) `(,(G 'list) ,@(map (g vs exp) u))) - (values ,(exp vs (car l)))))))))) + (,cvalues ,(exp vs (car l)))))))))) (#:return ((_ x) @@ -1624,7 +1626,7 @@ (#:None (E 'None)) (#:null ''()) (#:False #f) - (#:pass `(values)) + (#:pass `(,cvalues)) (#:break (C 'break)) (#:continue @@ -1675,7 +1677,7 @@ (define ,fnm (make-hash-table)) ,@(map (lambda (s) (if (member s (fluid-ref ignore)) - `(values) + `(,cvalues) `(,(C 'var) ,s))) globs) ,@e (,(C 'export-all))))) @@ -1696,7 +1698,7 @@ (fluid-set! (@@ (system base message) %dont-warn-list) '()) ,@(map (lambda (s) (if (member s (fluid-ref ignore)) - `(values) + `(,cvalues) `(,(C 'var) ,s))) globs) ,@e))))) @@ -1854,15 +1856,15 @@ (x #'x))) (define (is-ec ret x tail) - (syntax-case x (let-syntax begin let if define @@) + (syntax-case x (let-syntax begin let let* if define @@) ((cond (p a ... b) ...) (equal? (syntax->datum #'cond) '(@ (guile) cond)) - (or - (or-map (lambda (x) (is-ec ret x #f)) - #'(a ... ...)) - (or-map (lambda (x) (is-ec ret x tail)) - #'(b ...)))) + (or + (or-map (lambda (x) (is-ec ret x #f)) + #'(a ... ...)) + (or-map (lambda (x) (is-ec ret x tail)) + #'(b ...)))) ((with-self u v a ... b) (equal? (syntax->datum #'with-self) @@ -1897,6 +1899,13 @@ (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)) (is-ec ret #'b tail))) + ((let* ((y x) ...) a ... b) + #t + (or + (or-map (lambda (x) (is-ec ret x #f)) #'(x ...)) + (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)) + (is-ec ret #'b tail))) + ((define . _) #t #f) @@ -1930,7 +1939,7 @@ ((_ ret l) (let ((code (analyze #'ret #'l))) (if (is-ec #'ret #'l #t) - #`(let/ec ret #,code) + #`(let/ec ret l) code)))))) (define-syntax var @@ -1978,6 +1987,11 @@ (q (apply f q))) f))))))) +(define (gen-temp x) + (syntax-case x () + ((x ...) (map gen-temp #'(x ...))) + (x (car (generate-temporaries (list #'x)))))) + (define-syntax cfor (lambda (x) (syntax-case x () @@ -2048,14 +2062,14 @@ (syntax-case x () ((_ (x ...) (in) code #f #f) (with-syntax ((inv (gentemp #'in)) - ((xx ...) (generate-temporaries #'(x ...)))) + ((xx ...) (gen-temp #'(x ...)))) #'(let ((inv (wrap-in in))) (catch StopIteration (lambda () (let lp () (call-with-values (lambda () (next inv)) (clambda (xx ...) - (set! x xx) ... + (cset! x xx) ... (with-sp ((break (values)) (continue (values))) code @@ -2064,14 +2078,14 @@ ((_ (x ...) (in ...) code #f #f) (with-syntax (((inv ...) (generate-temporaries #'(in ...))) - ((xx ...) (generate-temporaries #'(x ...)))) + ((xx ...) (gen-temp #'(x ...)))) #'(let ((inv (wrap-in in)) ...) (catch StopIteration (lambda () (let lp () (call-with-values (lambda () (values (next inv) ...)) (clambda (xx ...) - (set! x xx) ... + (cset! x xx) ... (with-sp ((break (values)) (continue (values))) code @@ -2080,7 +2094,7 @@ ((_ (x ...) (in) code #f #t) (with-syntax ((inv (gentemp #'in)) - ((xx ...) (generate-temporaries #'(x ...)))) + ((xx ...) (gen-temp #'(x ...)))) #'(let ((inv (wrap-in in))) (let lp () (let/ec break-ret @@ -2088,7 +2102,7 @@ (lambda () (call-with-values (lambda () (next inv)) (clambda (xx ...) - (set! x xx) ... + (cset! x xx) ... (let/ec continue-ret (with-sp ((break (break-ret)) (continue (continue-ret))) @@ -2098,7 +2112,7 @@ ((_ (x ...) (in ...) code #f #t) (with-syntax (((inv ...) (generate-temporaries #'(in ...))) - ((xx ...) (generate-temporaries #'(x ...)))) + ((xx ...) (gen-temp #'(x ...)))) #'(let ((inv (wrap-in in)) ...) (let lp () (let/ec break-ret @@ -2106,7 +2120,7 @@ (lambda () (call-with-values (lambda () (values (next inv) ...)) (clambda (xx ...) - (set! x xx) ... + (cset! x xx) ... (let/ec continue-ret (with-sp ((break (break-ret)) (continue (continue-ret))) @@ -2129,11 +2143,6 @@ ((x ...) #'(values (next x) ...))) (syntax-case x () ((x) #'(next x))))) - - (define (gen-temp x) - (syntax-case x () - ((x ...) (map gen-temp #'(x ...))) - (x (car (generate-temporaries (list #'x)))))) (syntax-case x () ((_ (x ...) (in) code else p) @@ -2379,14 +2388,26 @@ (define-syntax boolit - (syntax-rules (and or not < <= > >=) - ((_ (and x y)) (and (boolit x) (boolit y))) - ((_ (or x y)) (or (boolit x) (boolit y))) - ((_ (not x )) (not (boolit x))) - ((_ (< x y)) (< x y)) - ((_ (<= x y)) (<= x y)) - ((_ (> x y)) (> x y)) - ((_ (>= x y)) (>= x y)) + (syntax-rules (and eq? equal? or not < <= > >=) + ((_ (and x y)) (and (boolit x) (boolit y))) + ((_ (or x y)) (or (boolit x) (boolit y))) + ((_ (not x )) (not (boolit x))) + ((_ (< x y)) (< x y)) + ((_ (<= x y)) (<= x y)) + ((_ (> x y)) (> x y)) + ((_ (>= x y)) (>= x y)) + ((_ (eq? x y)) (eq? x y)) + ((_ (equal? x y)) (equal? x y)) + + ((_ ((@ (guile) eq? ) x y)) (eq? x y)) + ((_ ((@ (guile) equal?) x y)) (equal? x y)) + ((_ ((@ (guile) and ) x y)) (and (boolit x) (boolit y))) + ((_ ((@ (guile) or ) x y)) (or (boolit x) (boolit y))) + ((_ ((@ (guile) not ) x )) (not (boolit x))) + ((_ ((@ (guile) < ) x y)) (< x y)) + ((_ ((@ (guile) <= ) x y)) (<= x y)) + ((_ ((@ (guile) > ) x y)) (> x y)) + ((_ ((@ (guile) >= ) x y)) (>= x y)) ((_ #t) #t) ((_ #f) #f) ((_ x ) (bool x)))) diff --git a/modules/language/python/list.scm b/modules/language/python/list.scm index 99c4f59..5cdb3d3 100644 --- a/modules/language/python/list.scm +++ b/modules/language/python/list.scm @@ -182,15 +182,14 @@ ;;SLICE -(define-method (pylist-slice (o

) n1 n2 n3) +(define-method (pylist-slice (o

) . l) (aif it (ref o '__getslice__) - (it n1 n2 n3) + (apply it l) (next-method))) (define-method (pylist-slice (o ) n1 n2 n3) (define N (slot-ref o 'n)) (define (f n) (if (< n 0) (+ N n) n)) - (let* ((n1 (f (if (eq? n1 None) 0 n1))) (n2 (f (if (eq? n2 None) (slot-ref o 'n) n2))) (n3 (f (if (eq? n3 None) 1 n3))) @@ -425,16 +424,23 @@ (next-method))) ;;POP! -(define-method (pylist-pop! (o )) - (let* ((n (slot-ref o 'n)) - (m (- n 1)) - (vec (slot-ref o 'vec))) - (if (> n 0) - (let ((ret (vector-ref vec m))) - (slot-set! o 'n m) - (vector-set! vec m #f) - ret) - (raise IndexError "pop from empty list")))) +(define-method (pylist-pop! (o ) . l) + (let ((index (if (null? l) + #f + (car l)))) + (if index + (let ((x (pylist-ref o index))) + (pylist-delete! o index) + x) + (let* ((n (slot-ref o 'n)) + (m (- n 1)) + (vec (slot-ref o 'vec))) + (if (> n 0) + (let ((ret (vector-ref vec m))) + (slot-set! o 'n m) + (vector-set! vec m #f) + ret) + (raise IndexError "pop from empty list")))))) (define-method (pylist-pop! (o

) . l) (aif it (ref o 'pop) diff --git a/modules/language/python/module.scm b/modules/language/python/module.scm index 52ec88b..680cf15 100644 --- a/modules/language/python/module.scm +++ b/modules/language/python/module.scm @@ -180,7 +180,9 @@ (let* ((h (slot-ref self 'h)) (l '()) (m (_m self)) - (add (lambda (k . u) (set! l (cons (symbol->string k) l))))) + (add (lambda (k . u) + (if (not (in "-" (symbol->string k))) + (set! l (cons (symbol->string k) l)))))) (hash-for-each add h) (module-for-each add m) (py-list l)))) diff --git a/modules/language/python/module/_python.scm b/modules/language/python/module/_python.scm index 2fac0a1..d9cb1c9 100644 --- a/modules/language/python/module/_python.scm +++ b/modules/language/python/module/_python.scm @@ -9,6 +9,8 @@ #:use-module (language python exceptions ) #:use-module ((language python module string ) #:select ()) #:use-module ((language python module io ) #:select (open)) + #:use-module ((language python module sys ) + #:select ((stdout . _stdout))) #:use-module (language python def ) #:use-module (language python for ) #:use-module (language python try ) @@ -57,10 +59,16 @@ (define vars py-dict) (define print - (case-lambda - (() ((@ (guile) display) "\n")) - ((x) ((@ (guile) display) x ) (print)) - (l ((@ (guile) display) l ) (print)))) + (lam ((= file _stdout) (* l)) + (if file (set! file (ref file '_port))) + (with-output-to-port file + (lambda () + (apply + (case-lambda + (() ((@ (guile) display) "\n")) + ((x) ((@ (guile) display) x ) (print)) + (l ((@ (guile) display) l ) (print))) + l))))) (define (repr x) ((@ (guile) format) #f "~a" x)) (define abs py-abs) diff --git a/modules/language/python/module/io.scm b/modules/language/python/module/io.scm index 87a2ec8..058e62d 100644 --- a/modules/language/python/module/io.scm +++ b/modules/language/python/module/io.scm @@ -369,15 +369,18 @@ (define-python-class FileIO (RawIOBase) (define __init__ (lam (self name (= mode 'r') (= closefd #t) (= opener None)) - (if (pair? name) - (set self '_port (car name)) - (set self '_port - (open- (path-it name) - #:mode mode - #:closefd closefd - #:opener opener))) - (set self 'mode mode) - (set self 'name (cdr name))))) + (if (port? name) + (set self '_port name) + (begin + (if (pair? name) + (set self '_port (car name)) + (set self '_port + (open- (path-it name) + #:mode mode + #:closefd closefd + #:opener opener))) + (set self 'mode mode) + (set self 'name (cdr name))))))) (define-python-class BytesIO (BufferedIOBase) diff --git a/modules/language/python/module/optparse.py b/modules/language/python/module/optparse.py index 886e685..903b374 100644 --- a/modules/language/python/module/optparse.py +++ b/modules/language/python/module/optparse.py @@ -210,12 +210,14 @@ class HelpFormatter: short_first): self.parser = None self.indent_increment = indent_increment + if width is None: try: width = int(os.environ['COLUMNS']) except (KeyError, ValueError): width = 80 width -= 2 + self.width = width self.help_position = self.max_help_position = \ min(max_help_position, max(width - 20, indent_increment * 2)) @@ -1102,7 +1104,6 @@ class OptionGroup (OptionContainer): formatter.dedent() return result - class OptionParser (OptionContainer): """ @@ -1186,17 +1187,23 @@ class OptionParser (OptionContainer): add_help_option=True, prog=None, epilog=None): + OptionContainer.__init__( self, option_class, conflict_handler, description) + self.set_usage(usage) self.prog = prog self.version = version self.allow_interspersed_args = True self.process_default_values = True + if formatter is None: formatter = IndentedHelpFormatter() + self.formatter = formatter + self.formatter.set_parser(self) + self.epilog = epilog # Populate the option list; initial sources are the @@ -1205,10 +1212,8 @@ class OptionParser (OptionContainer): # _add_help_option() methods. self._populate_option_list(option_list, add_help=add_help_option) - self._init_parsing_state() - def destroy(self): """ Declare that you are done with this OptionParser. This cleans up @@ -1307,14 +1312,12 @@ class OptionParser (OptionContainer): if not self.process_default_values: # Old, pre-Optik 1.5 behaviour. return Values(self.defaults) - defaults = self.defaults.copy() for option in self._get_all_options(): default = defaults.get(option.dest) if isinstance(default, str): opt_str = option.get_opt_string() defaults[option.dest] = option.check_value(opt_str, default) - return Values(defaults) @@ -1367,6 +1370,7 @@ class OptionParser (OptionContainer): over after parsing options. """ rargs = self._get_args(args) + if values is None: values = self.get_default_values() @@ -1434,7 +1438,7 @@ class OptionParser (OptionContainer): del rargs[0] else: return # stop now, leave this arg in rargs - + # Say this is the original argument list: # [arg0, arg1, ..., arg(i-1), arg(i), arg(i+1), ..., arg(N-1)] # ^ diff --git a/modules/language/python/module/os.scm b/modules/language/python/module/os.scm index afed9d1..16ee6e6 100644 --- a/modules/language/python/module/os.scm +++ b/modules/language/python/module/os.scm @@ -212,16 +212,29 @@ (define __getitem__ (lambda (self k) - (let ((r ((@ (guile) getenv) (slot-ref (pystring k) 'str)))) + (let ((r ((@ (guile) getenv) + (catch #t + (lambda () + (pystring k)) + (lambda x + (raise (ValueError "cant stringify k in env[x]"))))))) (if r r (raise IndexError))))) (define __setitem__ - (lambda (self k v) - ((@ (guile) putenv) (slot-ref (pystring (+ k "=" v)) 'str)))) + (lambda (self k v) + (call-with-values + (lambda () + (catch #t + (lambda () + (values (pystring k) (pystring v))) + (lambda x + (raise (ValueError "not stringable in environ"))))) + (lambda (k v) + ((@ (guile) putenv) (pystring (+ k "=" v))))))) (define __delitem__ (lambda (self k) - ((@ (guile) putenv) (slot-ref (pystring k) 'str)))) + ((@ (guile) putenv) (pystring k)))) (define __iter__ (lambda (self) diff --git a/modules/language/python/module/python.scm b/modules/language/python/module/python.scm index 9f8defe..82c0cab 100644 --- a/modules/language/python/module/python.scm +++ b/modules/language/python/module/python.scm @@ -14,9 +14,10 @@ [(_ iface _ li) (let ((l 'li)) (module-for-each - (lambda (name . l) + (lambda (name . l) (if (not (member name l)) - (module-re-export! (current-module) ((@ (guile) list) name)))) + (module-re-export! (current-module) + ((@ (guile) list) (pk name))))) (resolve-interface 'iface)))])) (set! (@ (language python module os) path) diff --git a/modules/language/python/module/sys.scm b/modules/language/python/module/sys.scm index ed52118..fe0a4ea 100644 --- a/modules/language/python/module/sys.scm +++ b/modules/language/python/module/sys.scm @@ -2,6 +2,7 @@ #:use-module (rnrs bytevectors) #:use-module (language python exceptions) #:use-module (language python hash) + #:use-module (language python module io) #:use-module (language python try) #:use-module (language python module python) #:use-module (oop pf-objects) @@ -13,7 +14,7 @@ tarcebacklimit platform maxsize hash_info base_prefix)) -(define-syntax stdin +(define-syntax stdin_ (lambda (x) (syntax-case x (set!) ((set! stdin port) @@ -22,7 +23,7 @@ (error "sys.stdin is not a function")) (s #'(current-input-port))))) -(define-syntax stdout +(define-syntax stdout_ (lambda (x) (syntax-case x (set!) ((set! stdin port) @@ -31,7 +32,7 @@ (error "sys.stdin is not a function")) (s #'(current-output-port))))) -(define-syntax stderr +(define-syntax stderr_ (lambda (x) (syntax-case x (set!) ((set! stdin port) @@ -40,6 +41,10 @@ (error "sys.stdin is not a function")) (s #'(current-error-port))))) +(define stdin (FileIO stdin_ )) +(define stderr (FileIO stderr_)) +(define stdout (FileIO stdout_)) + (define __stdin__ stdin) (define __stdout__ stdout) (define __stderr__ stderr) -- cgit v1.2.3