Using saved parent location: http://bzr.savannah.gnu.org/r/emacs/trunk/ Now on revision 101045. ------------------------------------------------------------ revno: 101045 committer: Glenn Morris branch nick: trunk timestamp: Tue 2010-08-10 19:14:53 -0700 message: * lisp/emacs-lisp/pcase.el: Fix copyright header. diff: === modified file 'lisp/emacs-lisp/pcase.el' --- lisp/emacs-lisp/pcase.el 2010-08-10 13:18:14 +0000 +++ lisp/emacs-lisp/pcase.el 2010-08-11 02:14:53 +0000 @@ -1,6 +1,6 @@ ;;; pcase.el --- ML-style pattern-matching macro for Elisp -;; Copyright (C) 2010 Stefan Monnier +;; Copyright (C) 2010 Free Software Foundation, Inc. ;; Author: Stefan Monnier ;; Keywords: @@ -483,7 +483,7 @@ (pcase-u1 matches code vars then-rest) (pcase-u else-rest)))) (t (error "Unkown QPattern %s" qpat)))) - + (provide 'pcase) ;;; pcase.el ends here ------------------------------------------------------------ revno: 101044 committer: Michael Mauger branch nick: trunk timestamp: Tue 2010-08-10 19:04:32 -0400 message: Suppress continuation prompts in SQL interactive mode * progmodes/sql.el: Version 2.5 (sql-product-alist): Add :prompt-cont-regexp property for several database products. (sql-prompt-cont-regexp): New variable. (sql-output-newline-count, sql-output-by-send): New variables. Record number of newlines in input text. (sql-send-string): Handle multiple filters and count newlines. (sql-send-magic-terminator): Count terminator newline. (sql-interactive-remove-continuation-prompt): Filters output to remove continuation prompts; one for each newline. (sql-interactive-mode): Set up new variables, prompt regexp and output filter. (sql-mode-sqlite-font-lock-keywords): Correct some keywords. (sql-make-alternate-buffer-name): Correct buffer name in edge cases. diff: === modified file 'etc/NEWS' --- etc/NEWS 2010-08-10 13:18:14 +0000 +++ etc/NEWS 2010-08-10 23:04:32 +0000 @@ -283,6 +283,14 @@ The custom variable `sql-port' can be specified for connection to MySQL servers. +*** Command continuation prompts in SQL interactive mode are suppressed. +Multiple line commands in SQL interactive mode, generate command +continuation prompts which needlessly confuse the output. These +prompts are now filtered out from the output. This change impacts +multiple line SQL statements entered with C-j between each line, +statements yanked into the buffer and statements sent with +`sql-send-*' functions. + *** Custom variables control prompting for login parameters. Each supported product has a custom variable `sql-*-login-params' which is a list of the parameters to be prompted for before a @@ -302,7 +310,8 @@ be of the form ".+\.SUF" where SUF is the desired file suffix. When :completion is specified, the ARG corresponds to the PREDICATE -argument to the `completing-read' function. +argument to the `completing-read' function (a list of possible values +or a function returning such a list). *** Added `sql-connection-alist' to record login parameter values. An alist for recording different username, database and server === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2010-08-10 18:01:18 +0000 +++ lisp/ChangeLog 2010-08-10 23:04:32 +0000 @@ -1,3 +1,21 @@ +2010-08-10 Michael R. Mauger + + * progmodes/sql.el: Version 2.5 + (sql-product-alist): Add :prompt-cont-regexp property for several + database products. + (sql-prompt-cont-regexp): New variable. + (sql-output-newline-count, sql-output-by-send): New + variables. Record number of newlines in input text. + (sql-send-string): Handle multiple filters and count newlines. + (sql-send-magic-terminator): Count terminator newline. + (sql-interactive-remove-continuation-prompt): Filters output to + remove continuation prompts; one for each newline. + (sql-interactive-mode): Set up new variables, prompt regexp and + output filter. + (sql-mode-sqlite-font-lock-keywords): Correct some keywords. + (sql-make-alternate-buffer-name): Correct buffer name in edge + cases. + 2010-08-10 Stefan Monnier * emacs-lisp/pcase.el: New file. === modified file 'lisp/progmodes/sql.el' --- lisp/progmodes/sql.el 2010-08-07 23:57:07 +0000 +++ lisp/progmodes/sql.el 2010-08-10 23:04:32 +0000 @@ -5,7 +5,7 @@ ;; Author: Alex Schroeder ;; Maintainer: Michael Mauger -;; Version: 2.4 +;; Version: 2.5 ;; Keywords: comm languages processes ;; URL: http://savannah.gnu.org/cgi-bin/viewcvs/emacs/emacs/lisp/progmodes/sql.el ;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?SqlMode @@ -336,6 +336,7 @@ :sqli-comint-func sql-comint-db2 :prompt-regexp "^db2 => " :prompt-length 7 + :prompt-cont-regexp "^db2 (cont\.) => " :input-filter sql-escape-newlines-filter) (informix @@ -357,7 +358,8 @@ :sqli-login sql-ingres-login-params :sqli-comint-func sql-comint-ingres :prompt-regexp "^\* " - :prompt-length 2) + :prompt-length 2 + :prompt-cont-regexp "^\* ") (interbase :name "Interbase" @@ -401,6 +403,7 @@ :sqli-comint-func sql-comint-mysql :prompt-regexp "^mysql> " :prompt-length 6 + :prompt-cont-regexp "^ -> " :input-filter sql-remove-tabs-filter) (oracle @@ -412,6 +415,7 @@ :sqli-comint-func sql-comint-oracle :prompt-regexp "^SQL> " :prompt-length 5 + :prompt-cont-regexp "^\\s-*\\d+> " :syntax-alist ((?$ . "w") (?# . "w")) :terminator ("\\(^/\\|;\\)" . "/") :input-filter sql-placeholders-filter) @@ -424,8 +428,9 @@ :sqli-options sql-postgres-options :sqli-login sql-postgres-login-params :sqli-comint-func sql-comint-postgres - :prompt-regexp "^.*[#>] *" + :prompt-regexp "^.*=[#>] " :prompt-length 5 + :prompt-cont-regexp "^.*-[#>] " :input-filter sql-remove-tabs-filter :terminator ("\\(^[\\]g\\|;\\)" . ";")) @@ -448,7 +453,9 @@ :sqli-login sql-sqlite-login-params :sqli-comint-func sql-comint-sqlite :prompt-regexp "^sqlite> " - :prompt-length 8) + :prompt-length 8 + :prompt-cont-regexp "^ ...> " + :terminator ";") (sybase :name "Sybase" @@ -509,6 +516,10 @@ :prompt-length length of the prompt on the line. + :prompt-cont-regexp regular expression string that matches + the continuation prompt issued by the + product interpreter. + :input-filter function which can filter strings sent to the command interpreter. It is also used by the `sql-send-string', @@ -516,7 +527,8 @@ and `sql-send-buffer' functions. The function is passed the string sent to the command interpreter and must return the - filtered string. + filtered string. May also be a list of + such functions. :terminator the terminator to be sent after a `sql-send-string', `sql-send-region', @@ -1034,6 +1046,9 @@ You can change `sql-prompt-length' on `sql-interactive-mode-hook'.") +(defvar sql-prompt-cont-regexp nil + "Prompt pattern of statement continuation prompts.") + (defvar sql-alternate-buffer-name nil "Buffer-local string used to possibly rename the SQLi buffer. @@ -1969,10 +1984,9 @@ "abort" "action" "add" "after" "all" "alter" "analyze" "and" "as" "asc" "attach" "autoincrement" "before" "begin" "between" "by" "cascade" "case" "cast" "check" "collate" "column" "commit" "conflict" -"constraint" "create" "cross" "current_date" "current_time" -"current_timestamp" "database" "default" "deferrable" "deferred" -"delete" "desc" "detach" "distinct" "drop" "each" "else" "end" -"escape" "except" "exclusive" "exists" "explain" "fail" "for" +"constraint" "create" "cross" "database" "default" "deferrable" +"deferred" "delete" "desc" "detach" "distinct" "drop" "each" "else" +"end" "escape" "except" "exclusive" "exists" "explain" "fail" "for" "foreign" "from" "full" "glob" "group" "having" "if" "ignore" "immediate" "in" "index" "indexed" "initially" "inner" "insert" "instead" "intersect" "into" "is" "isnull" "join" "key" "left" "like" @@ -1987,9 +2001,9 @@ ;; SQLite Data types (sql-font-lock-keywords-builder 'font-lock-type-face nil "int" "integer" "tinyint" "smallint" "mediumint" "bigint" "unsigned" -"big" "int2" "int8" "character" "varchar" "varying" "nchar" "native " +"big" "int2" "int8" "character" "varchar" "varying" "nchar" "native" "nvarchar" "text" "clob" "blob" "real" "double" "precision" "float" -"numeric" "decimal" "boolean" "date" "datetime" +"numeric" "number" "decimal" "boolean" "date" "datetime" ) ;; SQLite Functions (sql-font-lock-keywords-builder 'font-lock-builtin-face nil @@ -2002,6 +2016,7 @@ "typeof" "upper" "zeroblob" ;; Date/time functions "time" "julianday" "strftime" +"current_date" "current_time" "current_timestamp" ;; Aggregate functions "avg" "count" "group_concat" "max" "min" "sum" "total" ))) @@ -2585,25 +2600,33 @@ ;; Build a name using the :sqli-login setting (setq name (apply 'concat - (apply 'append nil - (sql-for-each-login - (sql-get-product-feature sql-product :sqli-login) - (lambda (token type arg) - (cond - ((eq token 'user) (list "/" sql-user)) - ((eq token 'port) (list ":" sql-port)) - ((eq token 'server) - (list "." (if (eq type :file) - (file-name-nondirectory sql-server) - sql-server))) - ((eq token 'database) - (list "@" (if (eq type :file) - (file-name-nondirectory sql-database) - sql-database))) - - ((eq token 'password) nil) - (t nil))))))) - + (cdr + (apply 'append nil + (sql-for-each-login + (sql-get-product-feature sql-product :sqli-login) + (lambda (token type arg) + (cond + ((eq token 'user) + (unless (string= "" sql-user) + (list "/" sql-user))) + ((eq token 'port) + (unless (= 0 sql-port) + (list ":" sql-port))) + ((eq token 'server) + (unless (string= "" sql-server) + (list "." + (if (eq type :file) + (file-name-nondirectory sql-server) + sql-server)))) + ((eq token 'database) + (when (string= "" sql-database) + (list "@" + (if (eq type :file) + (file-name-nondirectory sql-database) + sql-database)))) + + ((eq token 'password) nil) + (t nil)))))))) ;; If there's a connection, use it and the name thus far (if sql-connection @@ -2623,8 +2646,8 @@ sql-server) sql-database)) - ;; We've got a name, go with it (without the first punctuation char) - (substring name 1))))) + ;; Use the name we've got + name)))) (defun sql-rename-buffer () "Rename a SQLi buffer." @@ -2702,14 +2725,73 @@ ;;; Input sender for SQLi buffers +(defvar sql-output-newline-count 0 + "Number of newlines in the input string. + +Allows the suppression of continuation prompts.") + +(defvar sql-output-by-send nil + "Non-nil if the command in the input was generated by `sql-send-string'.") + (defun sql-input-sender (proc string) "Send STRING to PROC after applying filters." (let* ((product (with-current-buffer (process-buffer proc) sql-product)) (filter (sql-get-product-feature product :input-filter))) + ;; Apply filter(s) + (cond + ((not filter) + nil) + ((functionp filter) + (setq string (funcall filter string))) + ((listp filter) + (mapc (lambda (f) (setq string (funcall f string))) filter)) + (t nil)) + + ;; Count how many newlines in the string + (setq sql-output-newline-count 0) + (mapc (lambda (ch) + (when (eq ch ?\n) + (setq sql-output-newline-count (1+ sql-output-newline-count)))) + string) + ;; Send the string - (comint-simple-send proc (if filter (funcall filter string) string)))) + (comint-simple-send proc string))) + +;;; Strip out continuation prompts + +(defun sql-interactive-remove-continuation-prompt (oline) + "Strip out continuation prompts out of the OLINE. + +Added to the `comint-preoutput-filter-functions' hook in a SQL +interactive buffer. If `sql-outut-newline-count' is greater than +zero, then an output line matching the continuation prompt is filtered +out. If the count is one, then the prompt is replaced with a newline +to force the output from the query to appear on a new line." + (if (and sql-prompt-cont-regexp + sql-output-newline-count + (numberp sql-output-newline-count) + (>= sql-output-newline-count 1)) + (progn + (while (and oline + sql-output-newline-count + (> sql-output-newline-count 0) + (string-match sql-prompt-cont-regexp oline)) + + (setq oline + (replace-match (if (and + (= 1 sql-output-newline-count) + sql-output-by-send) + "\n" "") + nil nil oline) + sql-output-newline-count + (1- sql-output-newline-count))) + (if (= sql-output-newline-count 0) + (setq sql-output-newline-count nil)) + (setq sql-output-by-send nil)) + (setq sql-output-newline-count nil)) + oline) ;;; Sending the region to the SQLi buffer. @@ -2717,26 +2799,20 @@ "Send the string STR to the SQL process." (interactive "sSQL Text: ") - (let (comint-input-sender-no-newline proc) + (let ((comint-input-sender-no-newline nil) + (s (replace-regexp-in-string "[[:space:]\n\r]+\\'" "" str))) (if (buffer-live-p sql-buffer) (progn ;; Ignore the hoping around... (save-excursion - ;; Get the process - (setq proc (get-buffer-process sql-buffer)) - ;; Set product context (with-current-buffer sql-buffer - ;; Send the string - (sql-input-sender proc str) - - ;; Send a newline if there wasn't one on the end of the string - (unless (string-equal "\n" (substring str (1- (length str)))) - (comint-send-string proc "\n")) + ;; Send the string (trim the trailing whitespace) + (sql-input-sender (get-buffer-process sql-buffer) s) ;; Send a command terminator if we must (if sql-send-terminator - (sql-send-magic-terminator sql-buffer str sql-send-terminator)) + (sql-send-magic-terminator sql-buffer s sql-send-terminator)) (message "Sent string to buffer %s." (buffer-name sql-buffer)))) @@ -2771,7 +2847,7 @@ (defun sql-send-magic-terminator (buf str terminator) "Send TERMINATOR to buffer BUF if its not present in STR." - (let (pat term) + (let (comint-input-sender-no-newline pat term) ;; If flag is merely on(t), get product-specific terminator (if (eq terminator t) (setq terminator (sql-get-product-feature sql-product :terminator))) @@ -2792,8 +2868,13 @@ ;; Check to see if the pattern is present in the str already sent (unless (and pat term - (string-match (concat pat "\n?\\'") str)) - (comint-send-string buf (concat term "\n"))))) + (string-match (concat pat "\\'") str)) + (comint-simple-send (get-buffer-process buf) term) + (setq sql-output-newline-count + (if sql-output-newline-count + (1+ sql-output-newline-count) + 1))) + (setq sql-output-by-send t))) (defun sql-remove-tabs-filter (str) "Replace tab characters with spaces." @@ -2993,12 +3074,22 @@ (sql-get-product-feature sql-product :prompt-regexp)) (set (make-local-variable 'sql-prompt-length) (sql-get-product-feature sql-product :prompt-length)) + (set (make-local-variable 'sql-prompt-cont-regexp) + (sql-get-product-feature sql-product :prompt-cont-regexp)) + (make-local-variable 'sql-output-newline-count) + (make-local-variable 'sql-output-by-send) + (add-hook 'comint-preoutput-filter-functions + 'sql-interactive-remove-continuation-prompt nil t) (make-local-variable 'sql-input-ring-separator) (make-local-variable 'sql-input-ring-file-name) ;; Run the mode hook (along with comint's hooks). (run-mode-hooks 'sql-interactive-mode-hook) ;; Set comint based on user overrides. - (setq comint-prompt-regexp sql-prompt-regexp) + (setq comint-prompt-regexp + (if sql-prompt-cont-regexp + (concat "\\(" sql-prompt-regexp + "\\|" sql-prompt-cont-regexp "\\)") + sql-prompt-regexp)) (setq left-margin sql-prompt-length) ;; Install input sender (set (make-local-variable 'comint-input-sender) 'sql-input-sender) ------------------------------------------------------------ revno: 101043 committer: Ulf Jasper branch nick: trunk timestamp: Tue 2010-08-10 20:01:18 +0200 message: Fixed my ChangeLog entry of 2010-08-08 diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2010-08-10 13:18:14 +0000 +++ lisp/ChangeLog 2010-08-10 18:01:18 +0000 @@ -132,15 +132,19 @@ * align.el (align-default-spacing): Doc fix. (align-region-heuristic, align-regexp): Fix typos in docstrings. +2010-08-08 Stephen Peters + + * calendar/icalendar.el + (icalendar--split-value): Fixed splitting regexp. (Bug#6766) + (icalendar--get-weekday-numbers): New + (icalendar--convert-recurring-to-diary): Handle multiple byday + values in weekly rules. (Bug#6766) + 2010-08-08 Ulf Jasper * calendar/icalendar.el (icalendar-uid-format): Doc fix. - (icalendar--split-value): Fixed splitting regexp. (Bug#6766) - (icalendar--get-weekday-numbers): New (icalendar--create-uid, icalendar-export-region) (icalendar--parse-summary-and-rest): Code formatting. - (icalendar--convert-recurring-to-diary): Handle multiple byday - values in weekly rules. (Bug#6766) 2010-08-08 Jay Belanger ------------------------------------------------------------ revno: 101042 committer: Dan Nicolaescu branch nick: trunk timestamp: Tue 2010-08-10 07:22:29 -0700 message: * configure.in (AC_PREREQ): Require autoconf 2.65. diff: === modified file 'ChangeLog' --- ChangeLog 2010-08-09 20:01:51 +0000 +++ ChangeLog 2010-08-10 14:22:29 +0000 @@ -1,3 +1,7 @@ +2010-08-10 Dan Nicolaescu + + * configure.in (AC_PREREQ): Require autoconf 2.65. + 2010-08-09 Dan Nicolaescu * configure.in (AC_PREREQ): Require autoconf 2.66 to stop version churn. === modified file 'configure.in' --- configure.in 2010-08-09 20:01:51 +0000 +++ configure.in 2010-08-10 14:22:29 +0000 @@ -23,7 +23,7 @@ dnl You should have received a copy of the GNU General Public License dnl along with GNU Emacs. If not, see . -AC_PREREQ(2.66) +AC_PREREQ(2.65) AC_INIT(emacs, 24.0.50) AC_CONFIG_HEADER(src/config.h:src/config.in) AC_CONFIG_SRCDIR(src/lisp.h) ------------------------------------------------------------ revno: 101041 committer: Stefan Monnier branch nick: trunk timestamp: Tue 2010-08-10 15:18:14 +0200 message: * lisp/emacs-lisp/pcase.el: New file. diff: === modified file 'etc/NEWS' --- etc/NEWS 2010-08-07 19:39:04 +0000 +++ etc/NEWS 2010-08-10 13:18:14 +0000 @@ -371,6 +371,8 @@ * New Modes and Packages in Emacs 24.1 +** pcase.el provides the ML-style pattern matching macro `pcase'. + ** smie.el is a package providing a simple generic indentation engine. ** secrets.el is an implementation of the Secret Service API, an === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2010-08-10 09:58:15 +0000 +++ lisp/ChangeLog 2010-08-10 13:18:14 +0000 @@ -1,10 +1,14 @@ +2010-08-10 Stefan Monnier + + * emacs-lisp/pcase.el: New file. + 2010-08-10 Michael Albinus * net/tramp.el (tramp-vc-registered-read-file-names): Read input as here-document, otherwise the command could exceed maximum length of command line. - (tramp-handle-vc-registered): Call script accordingly. Reported - by Toru TSUNEYOSHI . + (tramp-handle-vc-registered): Call script accordingly. + Reported by Toru TSUNEYOSHI . 2010-08-10 Kenichi Handa @@ -21,11 +25,11 @@ (package-installed-p, package-compute-transaction) (package-read-all-archive-contents) (package--add-to-archive-contents, package-buffer-info) - (package-tar-file-info, package-list-packages-internal): Use - version-to-list and version-list-*. + (package-tar-file-info, package-list-packages-internal): + Use version-to-list and version-list-*. - * emacs-lisp/package-x.el (package-upload-buffer-internal): Use - version-to-list. + * emacs-lisp/package-x.el (package-upload-buffer-internal): + Use version-to-list. (package-upload-buffer-internal): Use version-list-<=. 2010-08-09 Kenichi Handa === added file 'lisp/emacs-lisp/pcase.el' --- lisp/emacs-lisp/pcase.el 1970-01-01 00:00:00 +0000 +++ lisp/emacs-lisp/pcase.el 2010-08-10 13:18:14 +0000 @@ -0,0 +1,489 @@ +;;; pcase.el --- ML-style pattern-matching macro for Elisp + +;; Copyright (C) 2010 Stefan Monnier + +;; Author: Stefan Monnier +;; Keywords: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; ML-style pattern matching. +;; The entry points are autoloaded. + +;;; Code: + +(eval-when-compile (require 'cl)) + +;; Macro-expansion of pcase is reasonably fast, so it's not a problem +;; when byte-compiling a file, but when interpreting the code, if the pcase +;; is in a loop, the repeated macro-expansion becomes terribly costly, so we +;; memoize previous macro expansions to try and avoid recomputing them +;; over and over again. +(defconst pcase-memoize (make-hash-table :weakness t :test 'equal)) + +;;;###autoload +(defmacro pcase (exp &rest cases) + "Perform ML-style pattern matching on EXP. +CASES is a list of elements of the form (UPATTERN CODE...). + +UPatterns can take the following forms: + _ matches anything. + SYMBOL matches anything and binds it to SYMBOL. + (or UPAT...) matches if any of the patterns matches. + (and UPAT...) matches if all the patterns match. + `QPAT matches if the QPattern QPAT matches. + (pred PRED) matches if PRED applied to the object returns non-nil. + +QPatterns can take the following forms: + (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr. + ,UPAT matches if the UPattern UPAT matches. + ATOM matches if the object is `eq' to ATOM. +QPatterns for vectors are not implemented yet. + +PRED can take the form + FUNCTION in which case it gets called with one argument. + (FUN ARG1 .. ARGN) in which case it gets called with N+1 arguments. +A PRED of the form FUNCTION is equivalent to one of the form (FUNCTION). +PRED patterns can refer to variables bound earlier in the pattern. +E.g. you can match pairs where the cdr is larger than the car with a pattern +like `(,a . ,(pred (< a))) or, with more checks: +`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))" + (declare (indent 1) (debug case)) + (or (gethash (cons exp cases) pcase-memoize) + (puthash (cons exp cases) + (pcase-expand exp cases) + pcase-memoize))) + +;;;###autoload +(defmacro pcase-let* (bindings body) + "Like `let*' but where you can use `pcase' patterns for bindings. +BODY should be an expression, and BINDINGS should be a list of bindings +of the form (UPAT EXP)." + (if (null bindings) body + `(pcase ,(cadr (car bindings)) + (,(caar bindings) (plet* ,(cdr bindings) ,body)) + (t (error "Pattern match failure in `plet'"))))) + +;;;###autoload +(defmacro pcase-let (bindings body) + "Like `let' but where you can use `pcase' patterns for bindings. +BODY should be an expression, and BINDINGS should be a list of bindings +of the form (UPAT EXP)." + (if (null (cdr bindings)) + `(plet* ,bindings ,body) + (setq bindings (mapcar (lambda (x) (cons (make-symbol "x") x)) bindings)) + `(let ,(mapcar (lambda (binding) (list (nth 0 binding) (nth 2 binding))) + bindings) + (plet* ,(mapcar (lambda (binding) (list (nth 1 binding) (nth 0 binding))) + bindings) + ,body)))) + +(defun pcase-expand (exp cases) + (let* ((defs (if (symbolp exp) '() + (let ((sym (make-symbol "x"))) + (prog1 `((,sym ,exp)) (setq exp sym))))) + (seen '()) + (codegen + (lambda (code vars) + (let ((prev (assq code seen))) + (if (not prev) + (let ((res (pcase-codegen code vars))) + (push (list code vars res) seen) + res) + ;; Since we use a tree-based pattern matching + ;; technique, the leaves (the places that contain the + ;; code to run once a pattern is matched) can get + ;; copied a very large number of times, so to avoid + ;; code explosion, we need to keep track of how many + ;; times we've used each leaf and move it + ;; to a separate function if that number is too high. + ;; + ;; We've already used this branch. So it is shared. + (destructuring-bind (code prevvars res) prev + (unless (symbolp res) + ;; This is the first repeat, so we have to move + ;; the branch to a separate function. + (let ((bsym + (make-symbol (format "pcase-%d" (length defs))))) + (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code)) defs) + (setcar res 'funcall) + (setcdr res (cons bsym (mapcar #'cdr prevvars))) + (setcar (cddr prev) bsym) + (setq res bsym))) + (setq vars (copy-sequence vars)) + (let ((args (mapcar (lambda (pa) + (let ((v (assq (car pa) vars))) + (setq vars (delq v vars)) + (cdr v))) + prevvars))) + (when vars ;New additional vars. + (error "The vars %s are only bound in some paths" + (mapcar #'car vars))) + `(funcall ,res ,@args))))))) + (main + (pcase-u + (mapcar (lambda (case) + `((match ,exp . ,(car case)) + ,(apply-partially + (if (pcase-small-branch-p (cdr case)) + ;; Don't bother sharing multiple + ;; occurrences of this leaf since it's small. + #'pcase-codegen codegen) + (cdr case)))) + cases)))) + `(let ,defs ,main))) + +(defun pcase-codegen (code vars) + `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars) + ,@code)) + +(defun pcase-small-branch-p (code) + (and (= 1 (length code)) + (or (not (consp (car code))) + (let ((small t)) + (dolist (e (car code)) + (if (consp e) (setq small nil))) + small)))) + +;; Try to use `cond' rather than a sequence of `if's, so as to reduce +;; the depth of the generated tree. +(defun pcase-if (test then else) + (cond + ((eq else :pcase-dontcare) then) + ((eq (car-safe else) 'if) + `(cond (,test ,then) + (,(nth 1 else) ,(nth 2 else)) + (t ,@(nthcdr 3 else)))) + ((eq (car-safe else) 'cond) + `(cond (,test ,then) + ,@(cdr else))) + (t `(if ,test ,then ,else)))) + +(defun pcase-upat (qpattern) + (cond + ((eq (car-safe qpattern) '\,) (cadr qpattern)) + (t (list '\` qpattern)))) + +;; Note about MATCH: +;; When we have patterns like `(PAT1 . PAT2), after performing the `consp' +;; check, we want to turn all the similar patterns into ones of the form +;; (and (match car PAT1) (match cdr PAT2)), so you naturally need conjunction. +;; Earlier code hence used branches of the form (MATCHES . CODE) where +;; MATCHES was a list (implicitly a conjunction) of (SYM . PAT). +;; But if we have a pattern of the form (or `(PAT1 . PAT2) PAT3), there is +;; no easy way to eliminate the `consp' check in such a representation. +;; So we replaced the MATCHES by the MATCH below which can be made up +;; of conjunctions and disjunctions, so if we know `foo' is a cons, we can +;; turn (match foo . (or `(PAT1 . PAT2) PAT3)) into +;; (or (and (match car . `PAT1) (match cdr . `PAT2)) (match foo . PAT3)). +;; The downside is that we now have `or' and `and' both in MATCH and +;; in PAT, so there are different equivalent representations and we +;; need to handle them all. We do not try to systematically +;; canonicalize them to one form over another, but we do occasionally +;; turn one into the other. + +(defun pcase-u (branches) + "Expand matcher for rules BRANCHES. +Each BRANCH has the form (MATCH CODE . VARS) where +CODE is the code generator for that branch. +VARS is the set of vars already bound by earlier matches. +MATCH is the pattern that needs to be matched, of the form: + (match VAR . UPAT) + (and MATCH ...) + (or MATCH ...)" + (when (setq branches (delq nil branches)) + (destructuring-bind (match code &rest vars) (car branches) + (pcase-u1 (list match) code vars (cdr branches))))) + +(defun pcase-and (match matches) + (if matches `(and ,match ,@matches) match)) + +(defun pcase-split-match (sym splitter match) + (case (car match) + ((match) + (if (not (eq sym (cadr match))) + (cons match match) + (let ((pat (cddr match))) + (cond + ;; Hoist `or' and `and' patterns to `or' and `and' matches. + ((memq (car-safe pat) '(or and)) + (pcase-split-match sym splitter + (cons (car pat) + (mapcar (lambda (alt) + `(match ,sym . ,alt)) + (cdr pat))))) + (t (let ((res (funcall splitter (cddr match)))) + (cons (or (car res) match) (or (cdr res) match)))))))) + ((or and) + (let ((then-alts '()) + (else-alts '()) + (neutral-elem (if (eq 'or (car match)) :pcase-fail :pcase-succeed)) + (zero-elem (if (eq 'or (car match)) :pcase-succeed :pcase-fail))) + (dolist (alt (cdr match)) + (let ((split (pcase-split-match sym splitter alt))) + (unless (eq (car split) neutral-elem) + (push (car split) then-alts)) + (unless (eq (cdr split) neutral-elem) + (push (cdr split) else-alts)))) + (cons (cond ((memq zero-elem then-alts) zero-elem) + ((null then-alts) neutral-elem) + ((null (cdr then-alts)) (car then-alts)) + (t (cons (car match) (nreverse then-alts)))) + (cond ((memq zero-elem else-alts) zero-elem) + ((null else-alts) neutral-elem) + ((null (cdr else-alts)) (car else-alts)) + (t (cons (car match) (nreverse else-alts))))))) + (t (error "Uknown MATCH %s" match)))) + +(defun pcase-split-rest (sym splitter rest) + (let ((then-rest '()) + (else-rest '())) + (dolist (branch rest) + (let* ((match (car branch)) + (code&vars (cdr branch)) + (splitted + (pcase-split-match sym splitter match))) + (unless (eq (car splitted) :pcase-fail) + (push (cons (car splitted) code&vars) then-rest)) + (unless (eq (cdr splitted) :pcase-fail) + (push (cons (cdr splitted) code&vars) else-rest)))) + (cons (nreverse then-rest) (nreverse else-rest)))) + +(defun pcase-split-consp (syma symd pat) + (cond + ;; A QPattern for a cons, can only go the `then' side. + ((and (eq (car-safe pat) '\`) (consp (cadr pat))) + (let ((qpat (cadr pat))) + (cons `(and (match ,syma . ,(pcase-upat (car qpat))) + (match ,symd . ,(pcase-upat (cdr qpat)))) + :pcase-fail))) + ;; A QPattern but not for a cons, can only go the `else' side. + ((eq (car-safe pat) '\`) (cons :pcase-fail nil)))) + +(defun pcase-split-eq (elem pat) + (cond + ;; The same match will give the same result. + ((and (eq (car-safe pat) '\`) (equal (cadr pat) elem)) + (cons :pcase-succeed :pcase-fail)) + ;; A different match will fail if this one succeeds. + ((and (eq (car-safe pat) '\`) + ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) + ;; (consp (cadr pat))) + ) + (cons :pcase-fail nil)))) + +(defun pcase-split-memq (elems pat) + ;; Based on pcase-split-eq. + (cond + ;; The same match will give the same result. + ((and (eq (car-safe pat) '\`) (member (cadr pat) elems)) + (cons :pcase-succeed nil)) + ;; A different match will fail if this one succeeds. + ((and (eq (car-safe pat) '\`) + ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) + ;; (consp (cadr pat))) + ) + (cons :pcase-fail nil)))) + +(defun pcase-split-pred (upat pat) + ;; FIXME: For predicates like (pred (> a)), two such predicates may + ;; actually refer to different variables `a'. + (if (equal upat pat) + (cons :pcase-succeed :pcase-fail))) + +(defun pcase-fgrep (vars sexp) + "Check which of the symbols VARS appear in SEXP." + (let ((res '())) + (while (consp sexp) + (dolist (var (pcase-fgrep vars (pop sexp))) + (unless (memq var res) (push var res)))) + (and (memq sexp vars) (not (memq sexp res)) (push sexp res)) + res)) + +;; It's very tempting to use `pcase' below, tho obviously, it'd create +;; bootstrapping problems. +(defun pcase-u1 (matches code vars rest) + "Return code that runs CODE (with VARS) if MATCHES match. +and otherwise defers to REST which is a list of branches of the form +\(ELSE-MATCH ELSE-CODE . ELSE-VARS)." + ;; Depending on the order in which we choose to check each of the MATCHES, + ;; the resulting tree may be smaller or bigger. So in general, we'd want + ;; to be careful to chose the "optimal" order. But predicate + ;; patterns make this harder because they create dependencies + ;; between matches. So we don't bother trying to reorder anything. + (cond + ((null matches) (funcall code vars)) + ((eq :pcase-fail (car matches)) (pcase-u rest)) + ((eq :pcase-succeed (car matches)) + (pcase-u1 (cdr matches) code vars rest)) + ((eq 'and (caar matches)) + (pcase-u1 (append (cdar matches) (cdr matches)) code vars rest)) + ((eq 'or (caar matches)) + (let* ((alts (cdar matches)) + (var (if (eq (caar alts) 'match) (cadr (car alts)))) + (simples '()) (others '())) + (when var + (dolist (alt alts) + (if (and (eq (car alt) 'match) (eq var (cadr alt)) + (let ((upat (cddr alt))) + (and (eq (car-safe upat) '\`) + (or (integerp (cadr upat)) (symbolp (cadr upat)))))) + (push (cddr alt) simples) + (push alt others)))) + (cond + ((null alts) (error "Please avoid it") (pcase-u rest)) + ((> (length simples) 1) + ;; De-hoist the `or' MATCH into an `or' pattern that will be + ;; turned into a `memq' below. + (pcase-u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches)) + code vars + (if (null others) rest + (cons (list* + (pcase-and (if (cdr others) + (cons 'or (nreverse others)) + (car others)) + (cdr matches)) + code vars) + rest)))) + (t + (pcase-u1 (cons (pop alts) (cdr matches)) code vars + (if (null alts) (progn (error "Please avoid it") rest) + (cons (list* + (pcase-and (if (cdr alts) + (cons 'or alts) (car alts)) + (cdr matches)) + code vars) + rest))))))) + ((eq 'match (caar matches)) + (destructuring-bind (op sym &rest upat) (pop matches) + (cond + ((memq upat '(t _)) (pcase-u1 matches code vars rest)) + ((eq upat 'dontcare) :pcase-dontcare) + ((functionp upat) (error "Feature removed, use (pred %s)" upat)) + ((eq (car-safe upat) 'pred) + (destructuring-bind (then-rest &rest else-rest) + (pcase-split-rest + sym (apply-partially 'pcase-split-pred upat) rest) + (pcase-if (if (symbolp (cadr upat)) + `(,(cadr upat) ,sym) + (let* ((exp (cadr upat)) + ;; `vs' is an upper bound on the vars we need. + (vs (pcase-fgrep (mapcar #'car vars) exp))) + (if vs + ;; Let's not replace `vars' in `exp' since it's + ;; too difficult to do it right, instead just + ;; let-bind `vars' around `exp'. + `(let ,(mapcar (lambda (var) + (list var (cdr (assq var vars)))) + vs) + ;; FIXME: `vars' can capture `sym'. E.g. + ;; (pcase x ((and `(,x . ,y) (pred (fun x))))) + (,@exp ,sym)) + `(,@exp ,sym)))) + (pcase-u1 matches code vars then-rest) + (pcase-u else-rest)))) + ((symbolp upat) + (pcase-u1 matches code (cons (cons upat sym) vars) rest)) + ((eq (car-safe upat) '\`) + (pcase-q1 sym (cadr upat) matches code vars rest)) + ((eq (car-safe upat) 'or) + (let ((all (> (length (cdr upat)) 1))) + (when all + (dolist (alt (cdr upat)) + (unless (and (eq (car-safe alt) '\`) + (or (symbolp (cadr alt)) (integerp (cadr alt)))) + (setq all nil)))) + (if all + ;; Use memq for (or `a `b `c `d) rather than a big tree. + (let ((elems (mapcar 'cadr (cdr upat)))) + (destructuring-bind (then-rest &rest else-rest) + (pcase-split-rest + sym (apply-partially 'pcase-split-memq elems) rest) + (pcase-if `(memq ,sym ',elems) + (pcase-u1 matches code vars then-rest) + (pcase-u else-rest)))) + (pcase-u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars + (append (mapcar (lambda (upat) + `((and (match ,sym . ,upat) ,@matches) + ,code ,@vars)) + (cddr upat)) + rest))))) + ((eq (car-safe upat) 'and) + (pcase-u1 (append (mapcar (lambda (upat) `(match ,sym ,@upat)) (cdr upat)) + matches) + code vars rest)) + ((eq (car-safe upat) 'not) + ;; FIXME: The implementation below is naive and results in + ;; inefficient code. + ;; To make it work right, we would need to turn pcase-u1's + ;; `code' and `vars' into a single argument of the same form as + ;; `rest'. We would also need to split this new `then-rest' argument + ;; for every test (currently we don't bother to do it since + ;; it's only useful for odd patterns like (and `(PAT1 . PAT2) + ;; `(PAT3 . PAT4)) which the programmer can easily rewrite + ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))). + (pcase-u1 `((match ,sym . ,(cadr upat))) + (lexical-let ((rest rest)) + ;; FIXME: This codegen is not careful to share its + ;; code if used several times: code blow up is likely. + (lambda (vars) + ;; `vars' will likely contain bindings which are + ;; not always available in other paths to + ;; `rest', so there' no point trying to pass + ;; them down. + (pcase-u rest))) + vars + (list `((and . ,matches) ,code . ,vars)))) + (t (error "Unknown upattern `%s'" upat))))) + (t (error "Incorrect MATCH %s" (car matches))))) + +(defun pcase-q1 (sym qpat matches code vars rest) + "Return code that runs CODE if SYM matches QPAT and if MATCHES match. +and if not, defers to REST which is a list of branches of the form +\(OTHER_MATCH OTHER-CODE . OTHER-VARS)." + (cond + ((eq (car-safe qpat) '\,) (error "Can't use `,UPATTERN")) + ((floatp qpat) (error "Floating point patterns not supported")) + ((vectorp qpat) + ;; FIXME. + (error "Vector QPatterns not implemented yet")) + ((consp qpat) + (let ((syma (make-symbol "xcar")) + (symd (make-symbol "xcdr"))) + (destructuring-bind (then-rest &rest else-rest) + (pcase-split-rest sym (apply-partially 'pcase-split-consp syma symd) + rest) + (pcase-if `(consp ,sym) + `(let ((,syma (car ,sym)) + (,symd (cdr ,sym))) + ,(pcase-u1 `((match ,syma . ,(pcase-upat (car qpat))) + (match ,symd . ,(pcase-upat (cdr qpat))) + ,@matches) + code vars then-rest)) + (pcase-u else-rest))))) + ((or (integerp qpat) (symbolp qpat)) + (destructuring-bind (then-rest &rest else-rest) + (pcase-split-rest sym (apply-partially 'pcase-split-eq qpat) rest) + (pcase-if `(eq ,sym ',qpat) + (pcase-u1 matches code vars then-rest) + (pcase-u else-rest)))) + (t (error "Unkown QPattern %s" qpat)))) + + +(provide 'pcase) +;;; pcase.el ends here ------------------------------------------------------------ revno: 101040 committer: Michael Albinus branch nick: trunk timestamp: Tue 2010-08-10 11:58:15 +0200 message: * net/tramp.el (tramp-vc-registered-read-file-names): Read input as here-document, otherwise the command could exceed maximum length of command line. (tramp-handle-vc-registered): Call script accordingly. Reported by Toru TSUNEYOSHI . diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2010-08-10 01:24:32 +0000 +++ lisp/ChangeLog 2010-08-10 09:58:15 +0000 @@ -1,3 +1,11 @@ +2010-08-10 Michael Albinus + + * net/tramp.el (tramp-vc-registered-read-file-names): Read input + as here-document, otherwise the command could exceed maximum + length of command line. + (tramp-handle-vc-registered): Call script accordingly. Reported + by Toru TSUNEYOSHI . + 2010-08-10 Kenichi Handa * language/hebrew.el: Exclude U+05C3 (Hebrew SOF PASUQ) from the === modified file 'lisp/net/tramp.el' --- lisp/net/tramp.el 2010-08-06 14:34:23 +0000 +++ lisp/net/tramp.el 2010-08-10 09:58:15 +0000 @@ -1983,13 +1983,13 @@ (defconst tramp-vc-registered-read-file-names "echo \"(\" -for file in \"$@\"; do - if %s $file; then +while read file; do + if %s \"$file\"; then echo \"(\\\"$file\\\" \\\"file-exists-p\\\" t)\" else echo \"(\\\"$file\\\" \\\"file-exists-p\\\" nil)\" fi - if %s $file; then + if %s \"$file\"; then echo \"(\\\"$file\\\" \\\"file-readable-p\\\" t)\" else echo \"(\\\"$file\\\" \\\"file-readable-p\\\" nil)\" @@ -1998,7 +1998,9 @@ echo \")\"" "Script to check existence of VC related files. It must be send formatted with two strings; the tests for file -existence, and file readability.") +existence, and file readability. Input shall be read via +here-document, otherwise the command could exceed maximum length +of command line.") (defconst tramp-file-mode-type-map '((0 . "-") ; Normal file (SVID-v2 and XPG2) @@ -5419,10 +5421,10 @@ (tramp-send-command-and-read v (format - "tramp_vc_registered_read_file_names %s" + "tramp_vc_registered_read_file_names <<'EOF'\n%s\nEOF\n" (mapconcat 'tramp-shell-quote-argument tramp-vc-registered-file-names - " ")))) + "\n")))) (tramp-set-file-property v (car elt) (cadr elt) (cadr (cdr elt)))))) @@ -8984,8 +8986,6 @@ ;; * Load Tramp subpackages only when needed. (Bug#1529, Bug#5448, Bug#5705) ;; * Try telnet+curl as new method. It might be useful for busybox, ;; without built-in uuencode/uudecode. -;; * Let `shell-dynamic-complete-*' and `comint-dynamic-complete' work -;; on remote hosts. ;; * Load ~/.emacs_SHELLNAME on the remote host for `shell'. ;; Functions for file-name-handler-alist: ------------------------------------------------------------ revno: 101039 [merge] committer: Kenichi Handa branch nick: trunk timestamp: Tue 2010-08-10 10:25:16 +0900 message: language/hebrew.el: Exclude U+05C3 (Hebrew SOF PASUQ) from the composable pattern. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2010-08-09 18:05:56 +0000 +++ lisp/ChangeLog 2010-08-10 01:24:32 +0000 @@ -1,3 +1,8 @@ +2010-08-10 Kenichi Handa + + * language/hebrew.el: Exclude U+05C3 (Hebrew SOF PASUQ) from the + composable pattern. + 2010-08-09 Chong Yidong * emacs-lisp/package.el (package-version-split) === modified file 'lisp/language/hebrew.el' --- lisp/language/hebrew.el 2010-08-09 08:12:49 +0000 +++ lisp/language/hebrew.el 2010-08-10 01:20:58 +0000 @@ -237,17 +237,24 @@ (setq idx (1+ idx)))))) gstring)) -(let ((pattern1 "[\u05D0-\u05F2][\u0591-\u05BD\u05BF\u05C1-\u05C5\u05C7]+") - (pattern2 "[\u05D0-\u05F2]\u200D[\u0591-\u05BD\u05BF\u05C1-\u05C5\u05C7]+")) +(let* ((base "[\u05D0-\u05F2]") + (combining "[\u0591-\u05BD\u05BF\u05C1-\u05C2\u05C4-\u05C5\u05C7]+") + (pattern1 (concat base combining)) + (pattern2 (concat base "\u200D" combining))) (set-char-table-range composition-function-table '(#x591 . #x5C7) (list (vector pattern2 3 'hebrew-shape-gstring) (vector pattern2 2 'hebrew-shape-gstring) (vector pattern1 1 'hebrew-shape-gstring) [nil 0 hebrew-shape-gstring])) + ;; Exclude non-combining characters. + (set-char-table-range + composition-function-table #x5BE nil) (set-char-table-range composition-function-table #x5C0 nil) (set-char-table-range + composition-function-table #x5C3 nil) + (set-char-table-range composition-function-table #x5C6 nil)) (provide 'hebrew) ------------------------------------------------------------ Use --include-merges or -n0 to see merged revisions.