@@ -14,7 +14,6 @@ (eval-when (:compile-toplevel) (error "This ASDF file should be run interpreted.")) - ;;; Core systems: parser, compiler, runtime ;; Here several ASDF systems are defined. The main system :clpython depends on all of them and has no @@ -35,8 +34,8 @@ #-allegro (:clpython.package :yacc) #+allegro #.`(:clpython.package ,@(when (asdf:find-system :yacc nil) `(:yacc))) :components ((:module "parser" - :components ((:file "psetup" ) - (:file "grammar" :depends-on ("psetup")) + :components ((:file "psetup" ) + (:file "grammar" :depends-on ("psetup")) (:file "lexer" :depends-on ("grammar")) (:file "parser" :depends-on ("grammar" "lexer")) (:file "grammar-aclyacc" :depends-on ("grammar" "lexer" "parser")) @@ -44,7 +43,7 @@ (:file "ast-match" :depends-on ("grammar")) (:file "ast-util" :depends-on ("ast-match" "grammar")) (:file "walk" :depends-on ("psetup")) - (:file "pprint" :depends-on ("psetup")) + (:file "pprint" :depends-on ("psetup")) (:file "lispy" :depends-on ("psetup" "parser" "ast-match")))))) (asdf:defsystem :clpython.core @@ -94,7 +93,7 @@ (:file "_socket" :depends-on ("lsetup")) (:file "sys" :depends-on ("lsetup")) (:file "string" :depends-on ("lsetup")) - (:file "symbol" :depends-on ("lsetup")) + (:file "symbol" :depends-on ("lsetup")) (:file "thread" :depends-on ("lsetup")) (:file "time" :depends-on ("lsetup")))))) @@ -104,8 +103,8 @@ :description "CLPython read-eval-print loop" :depends-on (:clpython.core) :components ((:module "app" - :components ((:module "repl" - :components ((:file "repl"))))))) + :components ((:module "repl" + :components ((:file "repl"))))))) (asdf:defsystem :clpython.app :description "CLPython applications" @@ -143,6 +142,43 @@ (defmethod asdf:perform :around ((op asdf:compile-op) (c (eql allegro-yacc-grammar))) nil))) +;; Give a nice error message when a required lib is not found. + +(defmacro with-missing-dep-help ((library warning-test) &body body) + `(handler-bind ((asdf:missing-dependency + (lambda (c) (when (eq (asdf::missing-requires c) ,library) + (warn ,warning-test))))) + ,@body)) + +(let ((clpython (asdf:find-system :clpython))) + + (defmethod asdf::traverse :around ((op asdf:compile-op) (system (eql clpython))) + (with-missing-dep-help (:closer-mop + "CL-Python requires library \"Closer to MOP\". ~ + Please check it out from the darcs repo: ~ + \"darcs get http://common-lisp.net/project/closer/repos/closer-mop\" ~ + or download the latest release from: ~ + http://common-lisp.net/project/closer/ftp/closer-mop_latest.tar.gz") + (call-next-method))) + + #-allegro + (defmethod asdf::traverse :around ((op asdf:compile-op) (system (eql clpython))) + (with-missing-dep-help (:yacc + "CL-Python requires library \"CL-Yacc\". ~ + Please check it out from the darcs repo: ~ + \"darcs get http://www.pps.jussieu.fr/~~jch/software/repos/cl-yacc\" ~ + or download the latest release from: ~ + http://www.pps.jussieu.fr/~~jch/software/files/") + (call-next-method))) + + #-allegro + (defmethod asdf::traverse :around ((op asdf:test-op) (system (eql clpython))) + (with-missing-dep-help (:ptester + "CL-Python requires library \"ptester\". ~ + Please download the latest release from: ~ + http://files.b9.com/ptester/ptester-latest.tar.gz") + (call-next-method)))) + ;;; Show usage (defun show-clpython-quick-start () @@ -162,6 +198,6 @@ (funcall (find-symbol (string '#:run-tests) :clpython.test))) (defmethod asdf:operation-done-p ((o asdf:test-op) - (c (eql (asdf:find-system :clpython)))) + (c (eql (asdf:find-system :clpython)))) "Testing is never finished." nil) clpython.asd @@ -652,7 +652,7 @@ otherwise work well.") (defgeneric function-name (f) (:method ((f function)) (let ((data (gethash f *simple-function-data*)) - (related-lisp-symbol #+allegro (string (excl::func_name f)) + (related-lisp-symbol #+allegro (excl::func_name f) #-allegro nil)) (values (if data (string (sfd-name data)) core/classes.lisp @@ -1122,7 +1122,7 @@ LOCALS shares share tail structure with input arg locals." (defvar *inside-import-from-stmt* nil) ;; hack -(defmacro [import-from-stmt] (mod-name-as-list items &environment e) +(defmacro [import-from-stmt] (mod-name-as-list items) `(let* ((*module-namespace* nil) ;; hack (args (list :within-mod-path ',(careful-derive-pathname *compile-file-truename* nil) :within-mod-name ',*current-module-name*)) @@ -1132,10 +1132,7 @@ LOCALS shares share tail structure with input arg locals." 'm `(apply #'py-import ',mod-name-as-list args)))) ,(case items - ([*] (assert (typep (get-pydecl :namespace e) 'hash-table-ns) - () "Can't do `from .. import *' in this namespace: ~A." - (get-pydecl :namespace e)) - `(loop for (k . v) in (dir-items mod-obj) + ([*] `(loop for (k . v) in (dir-items mod-obj) do (namespace-set-runtime (ensure-user-symbol k) v))) (t `(progn ,@(loop for (item bind-name) in items @@ -1166,6 +1163,15 @@ LOCALS shares share tail structure with input arg locals." (define-setf-expander [list-expr] (items &environment e) (get-setf-expansion `(list/tuple-expr ,items) e)) +(defmacro [literal-expr] (kind value) + (ecase kind + (:string (check-type value string) + value) + (:bytes (check-type value string) + `(TODO-make-bytes ,value)) ;; XXX TODO + (:number (check-type value number) + value))) + (defvar *habitat* nil) (defvar *module-preload-hook*) core/compiler.lisp @@ -113,8 +113,6 @@ (defvar *exception-classes* ()) (defun def-python-exceptions-1 (parent child-tree) - (declare (optimize (debug 3)) - (notinline def-python-exceptions)) (flet ((def-sub-exc (super exc-name) (push (define-exception-subclass exc-name super) *exception-classes*))) (if (symbolp child-tree) core/exceptions.lisp @@ -383,14 +383,14 @@ former requires that this form is executed within RECEIVE-YIELDED-VALUE." ([exec-stmt] ,@args)) ,(%call-continuation))) -(def-cps-macro [for-in-stmt] (target source suite else-suite) +(def-cps-macro [for-in-stmt] (target source suite else-suite &environment e) (with-gensyms (e-source it-fun for-cont for-break-cont else-cont ignore stmt-k) `(let ((,stmt-k ,%current-continuation)) (with-cps-conversion (,source ,e-source) (let* ((,it-fun (get-py-iterate-fun ,e-source))) - (labels (,@(when (contains-continue-stmt-p suite) + (labels (,@(when (contains-continue-stmt-p suite e) `((%continue-cont () (,for-cont)))) - ,@(when (contains-break-stmt-p suite) + ,@(when (contains-break-stmt-p suite e) `((%break-cont () (,for-break-cont)))) (,for-break-cont () (funcall ,stmt-k nil)) @@ -478,18 +478,19 @@ former requires that this form is executed within RECEIVE-YIELDED-VALUE." (def-cps-macro [listcompr-expr] (item for-in/if-clauses) (with-gensyms (result-list ignore) `(let ((,result-list (make-py-list-from-list ()))) + (with-pydecl ((:inside-cps-list-comprehension t)) ,(loop with builder = `([call-expr] ([attributeref-expr] ,result-list ([identifier-expr] {append})) (,item) nil nil nil) for clause in (reverse for-in/if-clauses) - do (setf builder - (ecase (car clause) - ([for-in-clause] (destructuring-bind (target source) (cdr clause) - `([for-in-stmt] ,target ,source ,builder nil))) - ([if-clause] (let ((test (second clause))) - `([if-stmt] ((,test ,builder)) nil))))) - finally (return `(with-cps-conversion (,builder ,ignore) - (declare (ignore ,ignore)) - ,(%call-continuation result-list))))))) + do (setf builder + (ecase (car clause) + ([for-in-clause] (destructuring-bind (target source) (cdr clause) + `([for-in-stmt] ,target ,source ,builder nil))) + ([if-clause] (let ((test (second clause))) + `([if-stmt] ((,test ,builder)) nil))))) + finally (return `(with-cps-conversion (,builder ,ignore) + (declare (ignore ,ignore)) + ,(%call-continuation result-list)))))))) (def-cps-macro [list-expr] (items) ;; Relies on tuples being Lisp lists. @@ -497,6 +498,10 @@ former requires that this form is executed within RECEIVE-YIELDED-VALUE." `(with-cps-conversion (([tuple-expr] ,items) ,e-tuple) ,(%call-continuation `(make-py-list-from-tuple ,e-tuple))))) +(def-cps-macro [literal-expr] (kind value) + (%call-continuation `(with-pydecl ((:ignore-cps-hook t)) + ([literal-expr] ,kind ,value)))) + (def-cps-macro [module-stmt] (&rest args) #+(or)(declare (ignore args)) ;; ends up in the wrong place args ;; so it's used @@ -660,8 +665,11 @@ former requires that this form is executed within RECEIVE-YIELDED-VALUE." `(with-cps-conversion (,val ,e-val) ,(%call-continuation `(funcall (function ,py-op-func) ,e-val)))))) -(defun contains-break-stmt-p (suite) +(defun contains-break-stmt-p (suite env) "Whether SUITE contains BREAK stmt (not within inner loop)." + (when (get-pydecl :inside-cps-list-comprehension env) + ;; List comprehension expansion is unwalkable; this is a hack to make the walker not crash. + (return-from contains-break-stmt-p nil)) (with-py-ast (form suite) (case (car form) (([for-in-stmt] [while-stmt]) (values nil t)) @@ -670,8 +678,11 @@ former requires that this form is executed within RECEIVE-YIELDED-VALUE." (t form))) nil) -(defun contains-continue-stmt-p (suite) +(defun contains-continue-stmt-p (suite env) "Whether SUITE contains BREAK stmt (not within inner loop)." + (when (get-pydecl :inside-cps-list-comprehension env) + ;; List comprehension expansion is unwalkable; this is a hack to make the walker not crash. + (return-from contains-continue-stmt-p nil)) (with-py-ast (form suite) (case (car form) (([for-in-stmt] [while-stmt]) (values nil t)) @@ -680,12 +691,12 @@ former requires that this form is executed within RECEIVE-YIELDED-VALUE." (t form))) nil) -(def-cps-macro [while-stmt] (test suite else-suite) +(def-cps-macro [while-stmt] (test suite else-suite &environment e) (let ((stmt-k %current-continuation)) (with-gensyms (while-cont val ignore) - `(labels (,@(when (contains-break-stmt-p suite) + `(labels (,@(when (contains-break-stmt-p suite e) `((%break-cont () (funcall ,stmt-k nil)))) - ,@(when (contains-continue-stmt-p suite) + ,@(when (contains-continue-stmt-p suite e) `((%continue-cont () (,while-cont)))) (,while-cont () (with-cps-conversion (,test ,val) core/generator.lisp @@ -356,10 +356,11 @@ (defmethod ns.attributes append ((x package-ns)) (list :package (ns.package x) :incl-builtins (ns.incl-builtins x))) -(defun package-ns-intern (ns s) - (check-type ns package-ns) - (check-type s symbol) - (intern (symbol-name s) (ns.package ns))) +(defgeneric package-ns-intern (ns s) + (:method ((ns package-ns) (s symbol)) + (package-ns-intern (ns.package ns) s)) + (:method ((package package) (s symbol)) + (intern (symbol-name s) package))) (defmethod ns.read-form ((ns package-ns) (s symbol)) (let ((ps (package-ns-intern ns s))) @@ -371,6 +372,11 @@ (let ((ps (package-ns-intern ns s))) `(setf (symbol-value ',ps) ,val-form))) +(defmethod ns.write-runtime-form ((ns package-ns) name-form val-form) + `(let ((.ps (package-ns-intern ,(ns.package ns) ,name-form))) + (warn "Setting ~A to ~S" .ps ,val-form) + (setf (symbol-value .ps) ,val-form))) + (defmethod ns.del-form ((ns package-ns) (s symbol)) (let ((ps (package-ns-intern ns s))) `(prog1 (boundp ',ps) core/namespace.lisp @@ -23,6 +23,7 @@ :inside-class-p ;; T iff inside CLASSDEF (to check GLOBAL). :inside-loop-p ;; T iff inside WHILE of FOR (to check BREAK, CONTINUE). :inside-setf-py-attr ;; T if insides a (setf (py-attr ..) ..) form (work around Allegro CL bug). + :inside-cps-list-comprehension ;; T iff inside CPS conversion of LISTCOMPR-EXPR :declared-globals-current-scope ;; List of variable that in the current scope must be treated as globals :lexically-declared-globals ;; Variables declared global by functions :lexically-visible-vars ;; List of variable names that can be closed over (excludes globals). core/pydecl.lisp @@ -63,7 +63,7 @@ (defpackage :clpython.ast.token (:use ) - (:export "newline" "indent" "dedent" "identifier" "number" "string")) + (:export "newline" "indent" "dedent" "identifier" "literal-expr")) (defpackage :clpython.ast.node (:documentation "Statement and expression nodes") package/package.lisp @@ -72,5 +72,5 @@ (raise-unexpected-eof)) (t (raise-syntax-error - (format nil "At line ~A, parser got unexpected token: `~A'." + (format nil "At line ~A, parser got unexpected token: ~S" line token))))))))) parser/grammar-aclyacc.lisp @@ -20,18 +20,16 @@ (:precedence ,(nreverse (get-precedence-and-associativity :left :right :nonassoc))) (:start-symbol clpython.parser::python-grammar) - ,@'#.(loop for name being each hash-key in *python-prods* - using (hash-value rules) - collect `(,name ,@(loop for (terms outcome options) in rules - for args = (loop for i from 1 to (length terms) - collect (intern (format nil "$~A" i) :clpython.parser)) - for func = `(lambda ,args - (declare (ignorable ,@args)) - ,outcome) - collect `(,@(or terms `(())) ;; splice term or insert () - ,@(if options - `((,func ,@options)) - `(,func))))))) + ,@(loop for name being each hash-key in *python-prods* + using (hash-value rules) + collect `(,name ,@(loop for (terms outcome) in rules + for args = (loop for i from 1 to (length terms) + collect (intern (format nil "$~A" i) :clpython.parser)) + for func = `(lambda ,args + (declare (ignorable ,@args)) + ,outcome) + collect `(,@(or terms `(())) ;; splice term or insert () + ,func))))) ;; For lexer parser/grammar-clyacc.lisp @@ -49,6 +49,7 @@ ([lambda-expr] args expr) ([listcompr-expr] item for-in/if-clauses) ([list-expr] items) + ([literal-expr] value) ([module-stmt] suite) ([pass-stmt] ) ([print-stmt] dest items comma?) @@ -139,7 +140,7 @@ (symbol-name x)))) (aref sn (1- (length sn)))))) (unless (some (lambda (x) (member (token-suffix x) '(#\? #\*))) terms) - (return-from p `(add-rule ',name ',terms ',outcome #| ,@options |# ))) + (return-from p `(add-rule ',name ',terms ',outcome))) (labels ((remove-token-suffix (x) (check-type x symbol) (let ((sn (symbol-name x))) @@ -181,17 +182,9 @@ Value should be a (weak) EQ hash table: (make-weak-key-hash-table :test 'eq).") (defparameter *module->source-positions* (make-hash-table :test 'equal) "EQ hashtable, mapping from pathname to source data. Filled during loading.") -(defstruct (literal (:constructor make-literal (value))) - value) - -(defun maybe-unwrap-literal-value (x) - (if (literal-p x) - (literal-value x) - x)) - (defun record-source-location (outcome start end) "Records location in *python-form->source-location*" - (check-type outcome (or list literal number string symbol)) ;; XXX reduce number of possibilities + (check-type outcome list) (when *python-form->source-location* (let ((existing (gethash outcome *python-form->source-location*)) (loc (list :start start :end end))) @@ -224,10 +217,10 @@ Value should be a (weak) EQ hash table: (make-weak-key-hash-table :test 'eq).") (when .min (record-source-location .outcome .min .max)) .outcome))))))) -(defun add-rule (name terms outcome &rest options) +(defun add-rule (name terms outcome) ;; Enable reduction trackin, for source form location recording purposes (let ((out (instrument-outcome terms outcome))) - (pushnew (list terms out options) (gethash name *python-prods*) :test 'equal))) + (pushnew (list terms out) (gethash name *python-prods*) :test 'equal))) (defmacro gp (name) "Generate a production rule: @@ -551,27 +544,39 @@ Value should be a (weak) EQ hash table: (make-weak-key-hash-table :test 'eq).") (( [{] dictmaker [}] ) `([dict-expr] ,$2) ) (( [`] testlist1 [`] ) `([backticks-expr] ,$2) ) (( [identifier] ) `([identifier-expr] ,$1) ) - (( [number] ) $1 ) - (( [.] [number] ) (let (($2val (literal-value $2)) - (suffix (float-suffix *normal-float-representation-type*))) - ;; A float value starting with a dot, like ".5" - ;; As NUMBER is a fraction between 0 and 1, it always falls in the range - ;; of the float representation type. - (make-literal - (typecase $2val - (integer (let ((str (format nil "0.~A~A0" $2val suffix))) - (with-standard-io-syntax (read-from-string str)))) - (complex (assert (zerop (realpart $2val))) - (assert (typep (imagpart $2val) 'integer)) - (let ((str (format nil "0.~A~A0" (imagpart $2val) suffix))) - (complex 0 (with-standard-io-syntax (read-from-string str))))) - (t (raise-syntax-error - "Invalid format for number starting with dot: .~G" $2val)))))) - (( string+ ) - ;; consecutive string literals are joined: "ab" "c" => "abc" - (make-literal (apply #'concatenate 'string (mapcar #'literal-value $1))))) - -(gp string+) + (( [.] [literal-expr] ) (destructuring-bind (kind value) (cdr $2) + (unless (eq kind :number) + (raise-syntax-error "Invalid literal number: .~A" (third $2))) + (let ((suffix (float-suffix *normal-float-representation-type*))) + ;; A float value starting with a dot, like ".5" + ;; As NUMBER is a fraction between 0 and 1, it always falls in the range + ;; of the float representation type. + `([literal-expr] + :number + ,(typecase value + (integer (let ((str (format nil "0.~A~A0" value suffix))) + (with-standard-io-syntax (read-from-string str)))) + (complex (assert (zerop (realpart value))) + (assert (typep (imagpart value) 'integer)) + (let ((str (format nil "0.~A~A0" (imagpart value) suffix))) + (complex 0 (with-standard-io-syntax (read-from-string str))))) + (t (raise-syntax-error + "Invalid format for number starting with dot: .~G" value))))))) + (( literal+ ) + ;; Consecutive string literals are joined: "ab" "c" => "abc". + ;; Same with byte literals: b'1' b'2' -> b'12'. + ;; But not mixed string/byte. + (if (> (length $1) 1) + (let ((types (remove-duplicates (mapcar #'second $1)))) + (if (and (= (length types) 1) + (member (car types) '(:string :bytes))) + (let ((first-literal (car $1))) + (list (first first-literal) (second first-literal) (apply #'concatenate 'string (mapcar #'third $1)))) + (raise-syntax-error "Invalid sequence of literals: ~:{~S ~S~:^, ~}." (mapcar #'cdr $1)))) + (car $1)))) + +(gp literal+) +(p literal ([literal-expr]) $1) (p listmaker (test list-for) `([listcompr-expr] ,$1 ,$2)) (p listmaker (test comma--test* comma?) `([list-expr] ,(cons $1 $2))) @@ -743,21 +748,9 @@ For example: - (1 * 2) => (-1) * 2" (setf res `([attributeref-expr] ,res ([identifier-expr] ,x)))))) (defun finish-ast (ast) - (prog1 (unwrap-literals ast) + (prog1 ast (clean-source-locations))) -(defun unwrap-literals (x) - (etypecase x - ((or symbol number) x) - (literal (literal-value x)) - (list (let ((res (mapcar #'unwrap-literals x))) - (when *python-form->source-location* - (let ((loc (gethash x *python-form->source-location*))) - (when loc - (setf (gethash res *python-form->source-location*) loc) - (remhash x *python-form->source-location*)))) - res)))) - (defun clean-source-locations () (declare (special *expr-stmt-nodes*)) (when *python-form->source-location* @@ -774,3 +767,7 @@ For example: - (1 * 2) => (-1) * 2" (clpython.parser::py-pprint k) (getf v :start) (getf v :end) (if (listp k) (car k) k))) ht))) +(defun maybe-unwrap-literal-value (x) + (if (and (listp x) (eq (car x) '[literal-expr])) + (third x) + x)) parser/grammar.lisp @@ -105,7 +105,7 @@ (multiple-value-bind (token value source-loc) (funcall lexer op) ;; Assuming eof-token is a symbol, which is true for acl/cl yacc: - (check-type value (or list literal symbol)) + (check-type value (or list symbol)) (when (and source-loc *python-form->source-location*) (setf (gethash value *python-form->source-location*) source-loc)) (values token value))))) @@ -187,7 +187,7 @@ On EOF returns: eof-token, eof-token." ((digit-char-p c 10) (multiple-value-bind (val source-loc) (read-kind :number c) - (lex-return '[number] (make-literal val) source-loc))) + (lex-return '[literal-expr] (list '[literal-expr] :number val) source-loc))) ((identifier-char1-p c) (multiple-value-bind (token source-loc) @@ -199,16 +199,26 @@ On EOF returns: eof-token, eof-token." ;; ur"asdf" : `ur' stands for `raw unicode string' ;; ur + a : `ur' is identifier ;; `u' must appear before `r' if both are string prefix + ;; Bytes (introduced in CPython 2.6): + ;; b"sdf" : bytes + ;; b'sdf' : bytes + ;; br"sdf" : raw bytes + ;; br'sdf' : raw bytes (when (and (<= (length (symbol-name token)) 2) - (member (symbol-name token) '("u" "r" "ur") :test 'string-equal)) + (member (sort (copy-seq (symbol-name token)) #'char-lessp) + '("r" "u" "ru" "b" "br") + :test 'string-equal)) (let ((ch (lex-read-char :eof-error nil))) (if (and ch (char-member ch '(#\' #\"))) (let* ((sn (symbol-name token)) (unicode (position #\u sn :test 'char-equal)) - (raw (position #\r sn :test 'char-equal))) + (raw (position #\r sn :test 'char-equal)) + (bytes (position #\b sn :test 'char-equal))) (multiple-value-bind (val source-loc) (read-kind :string ch :raw raw :unicode unicode) - (lex-return '[string] (make-literal val) source-loc))) + (lex-return '[literal-expr] + (list '[literal-expr] (if bytes :bytes :string) val) + source-loc))) (when ch (lex-unread-char ch))))) (when (and open-deco (eq token '[def])) ;; All outstanding decorators are associated with this function @@ -221,7 +231,7 @@ On EOF returns: eof-token, eof-token." ((char-member c '(#\' #\")) (multiple-value-bind (val source-loc) (read-kind :string c) - (lex-return '[string] (make-literal val) source-loc))) + (lex-return '[literal-expr] (list '[literal-expr] :string val) source-loc))) ((or (punct-char1-p c) (punct-char-not-punct-char1-p c)) parser/lexer.lisp @@ -50,79 +50,6 @@ output to a string does not start with a newline." (with-standard-io-syntax (format stream "~A" object))) -(defmethod py-pprint-1 (stream (x integer)) - (with-standard-io-syntax - (format stream "~D" x))) - -(defmethod py-pprint-1 (stream (x float)) - (with-standard-io-syntax - (format stream "~G" x))) - -(defmethod py-pprint-1 (stream (x complex)) - (assert (= 0 (realpart x))) - (with-standard-io-syntax - (format stream "~Gj" (imagpart x)))) - -(defmethod py-pprint-1 (stream (x string)) - (multiple-value-bind (delim-quote other-quote unicode?) - (loop for ch of-type character across x - counting (char= ch #\') into single-qs - counting (char= ch #\") into double-qs - counting (> (char-code ch) 255) into unicode - finally (let* ((delim-quote (if (<= single-qs double-qs) #\' #\")) - (other-quote (if (char= delim-quote #\') #\" #\')) - (unicode? (> unicode 0))) - (return (values delim-quote other-quote unicode?)))) - - (with-standard-io-syntax ;; no recursion please - - (when unicode? ;; unicode prefix 'u' - (write-char #\u stream)) - - (write-char delim-quote stream) ;; starting quote - - (loop for ch of-type character across (the string x) - do (cond ((char= ch delim-quote) (write-char #\\ stream) - (write-char ch stream)) - - ((char= ch other-quote) (write-char ch stream)) - - ((char= ch #\\) (write-char #\\ stream) - (write-char #\\ stream)) - - ;; printable ASCII character - ((and (<= (char-code ch) 127) - (graphic-char-p ch)) (write-char ch stream)) - - ((> (char-code ch) 255) - (format stream "\\u~v,vX" - (if (> (char-code ch) #xFFFF) 8 4) - #\0 (char-code ch))) - - ((alphanumericp ch) (write-char ch stream)) - - (t (loop for ch across - ;; Cross-reference: #'(read-kind (string) ..) does the inverse. - (case ch - (#\Bell "\\a") - (#\Backspace "\\b") - (#\Page "\\p") - (#\Newline "\\n") - (#\Return "\\r") - (#\Tab "\\t") - (#.(code-char 11) "\\v") ;; #\VT or #\PageUp - (#\Space " " ) - - ;; Maybe there are more cases to catch before - ;; we encode the character in octal code? - - (t (format nil "\\0~3,vO" #\0 (char-code ch)))) - - do (write-char ch stream))))) - - (write-char delim-quote stream)))) ;; closing quote - - (defvar *precedence-level* -1) ;; XXX check prec levels @@ -277,6 +204,9 @@ output to a string does not start with a newline." ([if-clause] (format stream " if ~A" (second clause))))) (format stream "]")) + ([literal-expr] (destructuring-bind (kind value) (cdr x) + (py-pprint-literal stream kind value))) + ([module-stmt] (let ((suite (cadr x))) (assert (eq (first suite) '[suite-stmt])) (format stream "~{~A~%~}" (second suite)))) @@ -367,7 +297,6 @@ output to a string does not start with a newline." ([yield-stmt] (format stream "yield~@[ ~A~]" (second x))) (t (format stream "(~{~S~^ ~})" x)))) - (defun print-arg-list (stream pos-args key-args *-arg **-arg) (let ((*precedence-level* -1) @@ -383,7 +312,78 @@ output to a string does not start with a newline." (format stream "~@[**~A~]" **-arg))) + +(defgeneric py-pprint-literal (stream kind value)) + +(defmethod py-pprint-literal :around (stream kind value) + (declare (ignore stream kind value)) + (with-standard-io-syntax + (call-next-method))) + +(defmethod py-pprint-literal (stream (kind (eql :number)) (x integer)) + (format stream "~D" x)) + +(defmethod py-pprint-literal (stream (kind (eql :number)) (x complex)) + (assert (= 0 (realpart x))) + (format stream "~Gj" (imagpart x))) + +(defmethod py-pprint-literal (stream (kind (eql :number)) (x float)) + (format stream "~G" x)) + +(defmethod py-pprint-literal (stream (kind (eql :bytes)) (x vector)) + (write-string "b'" stream) + (loop for item across x + do (when (characterp item) + (setf item (char-code item))) + (check-type item (unsigned-byte 8)) + (format stream "\\x~2,'0x" item)) + (write-string "'" stream)) + +(defmethod py-pprint-literal (stream (kind (eql :string)) (x string)) + (multiple-value-bind (delim-quote other-quote unicode?) + (loop for ch of-type character across x + counting (char= ch #\') into single-qs + counting (char= ch #\") into double-qs + counting (> (char-code ch) 255) into unicode + finally (let* ((delim-quote (if (<= single-qs double-qs) #\' #\")) + (other-quote (if (char= delim-quote #\') #\" #\')) + (unicode? (> unicode 0))) + (return (values delim-quote other-quote unicode?)))) + (when unicode? ;; unicode prefix 'u' + (write-char #\u stream)) + (write-char delim-quote stream) ;; starting quote + (loop for ch of-type character across (the string x) + do (cond ((char= ch delim-quote) (write-char #\\ stream) + (write-char ch stream)) + ((char= ch other-quote) (write-char ch stream)) + ((char= ch #\\) (write-char #\\ stream) + (write-char #\\ stream)) + ;; printable ASCII character + ((and (<= (char-code ch) 127) + (graphic-char-p ch)) (write-char ch stream)) + ((> (char-code ch) 255) + (format stream "\\u~v,vX" + (if (> (char-code ch) #xFFFF) 8 4) + #\0 (char-code ch))) + ((alphanumericp ch) (write-char ch stream)) + (t (loop for ch across + ;; Cross-reference: #'(read-kind (string) ..) does the inverse. + (case ch + (#\Bell "\\a") + (#\Backspace "\\b") + (#\Page "\\p") + (#\Newline "\\n") + (#\Return "\\r") + (#\Tab "\\t") + (#.(code-char 11) "\\v") ;; #\VT or #\PageUp + (#\Space " " ) + ;; Maybe there are more cases to catch before + ;; we encode the character in octal code? + (t (format nil "\\0~3,vO" #\0 (char-code ch)))) + do (write-char ch stream))))) + (write-char delim-quote stream))) ;; closing quote + ;; Utils (defun parse-and-print (str) - (py-pprint (parse str))) \ No newline at end of file + (py-pprint (parse str))) parser/pprint.lisp @@ -12,7 +12,6 @@ (in-package :clpython.parser) (in-syntax *ast-readtable*) -(defvar *walk-lists-only*) (defvar *walk-build-result*) (defvar *walk-into-nested-namespaces*) (defvar *walk-warn-unknown-form* t) @@ -37,8 +36,7 @@ (defun walk-py-ast (ast f &key (value +no-value+) (target +no-target+) - (lists-only t) - (build-result nil) + (build-result nil) (into-nested-namespaces nil) (warn-unknown-form *walk-warn-unknown-form*)) (declare (optimize (debug 3))) @@ -62,8 +60,6 @@ value, the second value must be true.) The initial form AST is considered an expression used for its value iff VALUE is true; it is considered an assignment target iff TARGET is true. -When LISTS-ONLY is false, F will also be called on numbers and strings. - When build-result is false, no new AST will be returned, so F is only called for side effects. @@ -74,9 +70,6 @@ CLASSDEF, FUNCDEF or LAMBDA." ;; module, is evaluated in a non-value non-target context, that ;; context seems a reasonable default for the keyword arguments. - (when (and lists-only (not (listp ast))) - (return-from walk-py-ast ast)) - (labels ((walk-py-ast-1 (ast &key value target) (declare (optimize (debug 3))) @@ -85,34 +78,29 @@ CLASSDEF, FUNCDEF or LAMBDA." (unless ast (break "Attempt to WALK-PY-AST into an AST that is NIL")) - (when (and lists-only (not (consp ast))) ;; Don't call user function on AST - (return-from walk-py-ast-1 ast)) - - ;; Call user function on whole form. The returned values + ;; Call user function on whole form. The returned values ;; control how we proceed. (multiple-value-bind (ret-ast final-p) (funcall f ast :value value :target target) (when final-p (return-from walk-py-ast-1 ret-ast)) - - (assert ret-ast () + + (assert ret-ast () "User AST func returned NIL (for AST: ~S); that is only allowed ~ when second value (final-p) is True, but second value was: ~S" ast final-p) - (when (or (consp ret-ast) (not lists-only)) - (return-from walk-py-ast-1 - (ast-recurse-fun (lambda (ast &key value target) - (walk-py-ast-1 ast :value value :target target)) - ret-ast - :value value - :target target))) + (return-from walk-py-ast-1 + (ast-recurse-fun (lambda (ast &key value target) + (walk-py-ast-1 ast :value value :target target)) + ret-ast + :value value + :target target)) - (break "Walking AST: invalid return value ~S (AST: ~S, F: ~S)" + (break "Walking AST: invalid return value ~S (AST: ~S, F: ~S)" ret-ast ast f)))) - (let ((*walk-lists-only* lists-only) - (*walk-build-result* build-result) + (let ((*walk-build-result* build-result) (*walk-into-nested-namespaces* into-nested-namespaces) (*walk-warn-unknown-form* warn-unknown-form)) @@ -240,6 +228,9 @@ CLASSDEF, FUNCDEF or LAMBDA." (def-ast-node [list-expr] ((&rest names +normal-value+)) (:targetable t) (:subtargetable t)) +;; Literal value itself (number, string) is not walked into. +(def-ast-node [literal-expr] (kind value)) + ;; listcompr-expr : hairy (def-ast-node [tuple-expr] ((&rest names +normal-value+)) (:targetable t) (:subtargetable t)) @@ -259,7 +250,7 @@ CLASSDEF, FUNCDEF or LAMBDA." (def-ast-node [try-finally-stmt] ((try-suite +suite+) (finally-suite +suite+))) -(def-ast-node [unary-expr] ((val +normal-value+))) +(def-ast-node [unary-expr] (op (val +normal-value+))) (def-ast-node [while-stmt] ((test +normal-value+) (suite +suite+) (&optional else-suite +suite+))) (def-ast-node [with-stmt] ((test +normal-value+) (&optional var +normal-target+) (suite +suite+))) (def-ast-node [yield-expr] ((val +normal-value+))) @@ -446,7 +437,7 @@ CLASSDEF, FUNCDEF or LAMBDA." ;; Handy functions for dealing with ASTs (defmacro with-py-ast ((subform ast &rest options) - ;; key value target walk-lists-only + ;; key value target ;; into-nested-namespaces &body body) ;; (with-sub-ast ((form &key value target) ast) @@ -463,18 +454,16 @@ CLASSDEF, FUNCDEF or LAMBDA." (lambda ,subform (declare (optimize (debug 3)) ,@(when context `((ignore ,context)))) - ,@body)) + ,@body)) ;; user-supplied options take precedence... ,@options ;; but these are the defaults - :build-result nil - :lists-only t))) + :build-result nil))) ;;; Printing walker, for debugging (defgeneric walk-print (ast &rest walk-options) (:method ((ast list) &rest walk-options) - (setf walk-options (append walk-options '(:lists-only nil))) (prog1 (apply #'walk-py-ast ast (lambda (ast &key value target) parser/walk.lisp @@ -664,10 +664,10 @@ assert sys" :fail-info "Should work in both ANSI and Modern mode.") (error "Compile file lang-test.lisp using compile-file (or asdf), not using temp file, ~ otherwise import paths are incorrect: ~A." *compile-file-truename*)) nil) - (let ((prefix (concatenate 'string " + (let* ((new-dir #.(directory-namestring (clpython::derive-pathname *compile-file-truename* :type nil :name nil))) + (prefix (concatenate 'string " import sys -sys.path.append('" #.(directory-namestring (clpython::derive-pathname *compile-file-truename* :type nil :name nil)) "data/') -"))) +sys.path.append('" (coerce (loop for c across new-dir if (char= c #\\) collect #\\ and collect #\\ else collect c) 'string) "data')" (string #\Newline)))) (format t "prefix: ~S~%" prefix) (clpython::%reset-import-state) ;; run compilation outside run-no-error, to prevent allegro style warning from failing the test test/lang-test.lisp @@ -10,5 +10,6 @@ (in-package :clpython.test) (defun run-mod-math-test () - (run-no-error "import math; assert 3.14 < math.pi < 3.15") - (run-no-error "import math; assert 2.71 < math.e < 2.72")) + (with-subtest (:name "module Math") + (run-no-error "import math; assert 3.14 < math.pi < 3.15") + (run-no-error "import math; assert 2.71 < math.e < 2.72"))) test/mod-math-test.lisp @@ -10,10 +10,11 @@ (in-package :clpython.test) (defun run-mod-string-test () - (run-no-error " + (with-subtest (:name "module String") + (run-no-error " import string t = string.maketrans('ab', 'xy') string.translate('abcdxyz', t, 'd') == 'xycxyz'") - (run-no-error " -assert '%% %s' % (1,) == '% 1'")) + (run-no-error " +assert '%% %s' % (1,) == '% 1'"))) \ No newline at end of file test/mod-string-test.lisp @@ -47,19 +47,20 @@ (test-true (find-symbol "foo" :clpython.user)) ;; created by previous test (test-true (eq '{abs} '{abs} )) - ;; atoms - (test-equal '([module-stmt] ([suite-stmt] (42))) (ps "42")) - (test-equal '([module-stmt] ([suite-stmt] ("x"))) (ps "'x'")) + ;; literals + (test-equal '([module-stmt] ([suite-stmt] (([literal-expr] :number 42)))) (ps "42")) + (test-equal '([module-stmt] ([suite-stmt] (([literal-expr] :string "x")))) (ps "'x'")) + (test-equal '([module-stmt] ([suite-stmt] (([literal-expr] :bytes "x")))) (ps "b'x'")) ;; variables - (test-equal '([assign-stmt] 3 (([identifier-expr] {y} ))) (ps "y = 3" nil)) - (test-equal '([assign-stmt] 3 (([identifier-expr] {len}))) (ps "len = 3" nil)) + (test-equal '([assign-stmt] ([literal-expr] :number 3) (([identifier-expr] {y} ))) (ps "y = 3" nil)) + (test-equal '([assign-stmt] ([literal-expr] :number 3) (([identifier-expr] {len}))) (ps "len = 3" nil)) ;; floating point (complex) numbers - (test-equal 0.5d0 (ps "0.5" nil)) - (test-equal 0.5d0 (ps ".5" nil)) - (test-equal #C(0.0 0.5d0) (ps "0.5j" nil)) - (test-equal #C(0.0 0.5d0) (ps ".5j" nil)) + (test-equal '([literal-expr] :number 0.5d0) (ps "0.5" nil)) + (test-equal '([literal-expr] :number 0.5d0) (ps ".5" nil)) + (test-equal '([literal-expr] :number #C(0.0 0.5d0)) (ps "0.5j" nil)) + (test-equal '([literal-expr] :number #C(0.0 0.5d0)) (ps ".5j" nil)) (assert (not (eq clpython.parser::*normal-float-representation-type* clpython.parser::*enormous-float-representation-type*)) @@ -68,7 +69,7 @@ (clpython.parser::number-range clpython.parser::*normal-float-representation-type*) (assert (< min-f 0)) (assert (< (expt 10 3) max-f) () "Really small float range in this Lisp implementation?!") - (test-equal 1D3 (ps "1e3" nil)) ;; 1e3 is small enough to be a regular ..-FLOAT + (test-equal '([literal-expr] :number 1D3) (ps "1e3" nil)) ;; 1e3 is small enough to be a regular ..-FLOAT (let* ((n-expt (1+ (floor (log max-f 10)))) (s (format nil "1E~A" n-expt))) (test-error (ps s nil) :condition-type '{SyntaxError}) ;; "too large to represent as ..-FLOAT" @@ -77,30 +78,31 @@ (test-true (find-restart 'continue)) (invoke-restart (find-restart 'continue))))) (ps s nil)) - (expt 10 n-expt)))) + `([literal-expr] :number ,(expt 10 n-expt))))) ;; suffix operations (test-equal '([attributeref-expr] ([call-expr] - ([subscription-expr] ([identifier-expr] {x}) 1) - (2) nil nil nil) + ([subscription-expr] ([identifier-expr] {x}) ([literal-expr] :number 1)) + (([literal-expr] :number 2)) nil nil nil) ([identifier-expr] {a3})) (ps "x[1](2).a3" nil)) ;; call arguments (test-equal '([attributeref-expr] ([call-expr] ([subscription-expr] ([identifier-expr] {x}) - 1) - nil ((([identifier-expr] {len}) 2)) nil nil) + ([literal-expr] :number 1)) + nil ((([identifier-expr] {len}) ([literal-expr] :number 2))) nil nil) ([identifier-expr] {a3})) (ps "x[1](len=2).a3" nil)) (test-equal '([call-expr] ([identifier-expr] {f}) - (1 2) ((([identifier-expr] {y}) 3)) + (([literal-expr] :number 1) ([literal-expr] :number 2)) + ((([identifier-expr] {y}) ([literal-expr] :number 3))) ([identifier-expr] {args}) ([identifier-expr] {kw})) - (ps "f(1,2, y=3, *args, **kw)" nil)) + (ps "f(1, 2, y=3, *args, **kw)" nil)) ;; order of args: pos, key, *, ** (test-error (ps "f(a=1,b)" nil) @@ -130,53 +132,61 @@ def f(): pass" nil)) ;; Precedence of unary operators and exponentiation (test-equal '([binary-expr] [*] - ([unary-expr] [-] 1) - 2) + ([unary-expr] [-] ([literal-expr] :number 1)) + ([literal-expr] :number 2)) (ps "-1 * 2" nil) :fail-info "-1 * 2 == (-1) * 2") (test-equal '([binary-expr] [*] - ([unary-expr] [+] 1) - 2) + ([unary-expr] [+] ([literal-expr] :number 1)) + ([literal-expr] :number 2)) (ps "+1 * 2" nil) :fail-info "+1 * 2 == (+1) * 2") - (test-equal '([unary-expr] [-] ([binary-expr] [**] 1 2)) + (test-equal '([unary-expr] [-] ([binary-expr] [**] + ([literal-expr] :number 1) + ([literal-expr] :number 2))) (ps "-1 ** 2" nil) :fail-info "-1 ** 2 == - (1 ** 2)") - (test-equal '([unary-expr] [+] ([binary-expr] [**] 1 2)) + (test-equal '([unary-expr] [+] ([binary-expr] [**] + ([literal-expr] :number 1) + ([literal-expr] :number 2))) (ps "+1 ** 2" nil) :fail-info "+1 ** 2 == + (1 ** 2)") (test-equal '([binary-expr] [-] - 1 - ([binary-expr] [*] 2 3)) + ([literal-expr] :number 1) + ([binary-expr] [*] + ([literal-expr] :number 2) + ([literal-expr] :number 3))) (ps "1 - 2 * 3" nil) :fail-info "1 - 2 * 3 == 1 - (2 * 3)") (test-equal '([binary-expr] [/] - ([unary-expr] [~] 1) - 2) + ([unary-expr] [~] ([literal-expr] :number 1)) + ([literal-expr] :number 2)) (ps "~1 / 2" nil) :fail-info "~1 / 2 == (~1) / 2") (test-equal '([unary-expr] [~] - ([binary-expr] [**] 1 2)) + ([binary-expr] [**] + ([literal-expr] :number 1) + ([literal-expr] :number 2))) (ps "~1 ** 2" nil) :fail-info "~1 ** 2 == ~ (1 ** 2)") (test-equal '([binary-expr] [*] - ([unary-expr] [-] 1) + ([unary-expr] [-] ([literal-expr] :number 1)) ([binary-expr] [*] - ([unary-expr] [+] 2) + ([unary-expr] [+] ([literal-expr] :number 2)) ([binary-expr] [*] - ([unary-expr] [-] 3) - ([unary-expr] [+] 4)))) + ([unary-expr] [-] ([literal-expr] :number 3)) + ([unary-expr] [+] ([literal-expr] :number 4))))) (ps "-1 * +2 * -3 * +4" nil)) (test-equal '([binary-expr] [*] - 1 + ([literal-expr] :number 1) ([unary-expr] [-] ([bracketed-expr] ([binary-expr] [*] ([bracketed-expr] ([binary-expr] [*] - ([unary-expr] [-] 2) - 3)) - 4)))) + ([unary-expr] [-] ([literal-expr] :number 2)) + ([literal-expr] :number 3))) + ([literal-expr] :number 4))))) (ps "1 * -((-2 * 3) * 4)" nil)) ;; Empty string is parsed as module without body @@ -190,7 +200,7 @@ def f(): pass" nil)) #+(and allegro unix) ;; no WITH-OPEN-TEMP-FILE on windows (let ((fname (excl.osi:with-open-temp-file (s (format nil "_clpython-ast-test-~A" (gensym))) (format s "print 42")))) - (test-equal '([print-stmt] nil (42) nil) + (test-equal '([print-stmt] nil (([literal-expr] :number 42)) nil) (values (clpython.parser:parse (pathname fname) :one-expr t))) (test t (excl.osi:unlink fname))) @@ -207,16 +217,17 @@ def f(): pass" nil)) (test :unexp-eof-error (try-parse "def f():") :fail-info "(EOF in grammar)") (test :syntax-error (try-parse "def def") :fail-info "(Incorrect grammar)") (test :syntax-error (try-parse " 42") :fail-info "(Leading whitespace)")) - (test-equal 42 (handler-bind (({SyntaxError} (lambda (c) (declare (ignore c)) - (continue)))) - (values (parse " 42" :one-expr t)))) + (test-equal '([literal-expr] :number 42) + (handler-bind (({SyntaxError} (lambda (c) (declare (ignore c)) + (continue)))) + (values (parse " 42" :one-expr t)))) ;; strings with quotes (let ((s (apply #'concatenate 'string (mapcar 'string '(#\' #\" #\\ #\' #\'))))) - (test-equal (values (parse s :one-expr t)) "\"'")) + (test-equal (values (parse s :one-expr t)) '([literal-expr] :string "\"'"))) (let ((s (apply #'concatenate 'string (mapcar 'string '(#\' #\\ #\\ #\'))))) - (test-equal (ignore-errors (values (parse s :one-expr t))) "\\")) + (test-equal (ignore-errors (values (parse s :one-expr t))) '([literal-expr] :string "\\"))) (let ((s (apply #'concatenate 'string (mapcar 'string '(#\' #\\ #\\ #\' #\Space))))) - (test-equal (ignore-errors (values (parse s :one-expr t))) "\\")) + (test-equal (ignore-errors (values (parse s :one-expr t))) '([literal-expr] :string "\\"))) ;; trailing comma (test-no-error (parse "def f(a=3,): pass")) ;; backslash at end of whitespace line @@ -265,6 +276,8 @@ else: ;; string (pe "'x'") (p "'\"'") + ;; bytes + (p "b'\\x41\\x42\\x03'") ;; assert (p "assert (1, 2, 3)") (p "assert x > 0, 'error'") @@ -489,13 +502,17 @@ finally: (p "(yield)") (p "(yield x)") (p "(yield x, y)") + (p "()") ))) (defun run-lispy-test () (let ((tests '(("()" (clpython.parser::handle-lisp nil)) ("(,)" :error) ("(f)" (clpython.parser::handle-lisp (f))) - ("(1,2)" (clpython.parser::handle-python ([module-stmt] ([suite-stmt] (([tuple-expr] (1 2)))))))))) + ("(1,2)" (clpython.parser::handle-python + ([module-stmt] ([suite-stmt] + (([tuple-expr] (([literal-expr] :number 1) + ([literal-expr] :number 2))))))))))) (loop for (test expected) in tests do (multiple-value-bind (val error) (ignore-errors (car (let ((*package* #.*package*)) test/parser-test.lisp @@ -9,12 +9,16 @@ ;;;; CLPython test harness setup +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :tester)) + (defpackage :clpython.test (:use :common-lisp :clpython) (:import-from :clpython #:in-syntax) (:import-from :clpython.parser #:parse) - (:import-from :ptester #:*announce-test* #:with-tests - #:test #:test-warning) + (:import-from #+allegro :util.test #-allegro :ptester + #:*announce-test* #:with-tests #:test #:test-warning) (:export #:run)) (in-package :clpython.test) @@ -29,10 +33,12 @@ ,form)) (defmacro test-no-error (form &rest args) - `(ptester:test-no-error ,(form-without-compiler-warnings form) ,@args)) + `(#+allegro util.test:test-no-error #-allegro ptester:test-no-error + ,(form-without-compiler-warnings form) ,@args)) (defmacro test-error (form &rest args) - `(ptester:test-error ,(form-without-compiler-warnings form) ,@args)) + `(#+allegro util.test:test-error #-allegro ptester:test-error + ,(form-without-compiler-warnings form) ,@args)) (defmacro test-true (val &rest options) "Only tests first value returned" test/tsetup.lisp 3de3587eaa25321fcc7b1c0232bd64acbbfa68a5 ce88957263d3ee0d2ab817cc5342feea472b3bb5 Willem Broekema metawilm@gmail.com http://github.com/franzinc/cl-python/commit/edd14820c9300096c869804a4afa11acec2c16f5 edd14820c9300096c869804a4afa11acec2c16f5 2009-11-02T16:04:31-08:00 2009-11-02T16:04:31-08:00 Merge commit 'ce88957263d3ee0d2ab817cc5342feea472b3bb5' 1b7b0e6fd2bcbb1a6ce8be24f54203dd937ab319 Willem Broekema metawilm@gmail.com