Mercurial > emacs
changeset 108899:f094e7889b4c
Merge from mainline.
| author | Katsumi Yamaoka <yamaoka@jpl.org> |
|---|---|
| date | Wed, 02 Jun 2010 22:44:58 +0000 |
| parents | bffeeada2cff (current diff) f241d9fe71fe (diff) |
| children | ff2d80da1816 |
| files | |
| diffstat | 23 files changed, 633 insertions(+), 244 deletions(-) [+] |
line wrap: on
line diff
--- a/ChangeLog Wed Jun 02 00:16:28 2010 +0000 +++ b/ChangeLog Wed Jun 02 22:44:58 2010 +0000 @@ -1,3 +1,9 @@ +2010-06-02 Dan Nicolaescu <dann@ics.uci.edu> + + Fix alloca definition when using gcc on non-gnu systems. + * configure.in: Use the code sequence indicated by "info autoconf" + for alloca (bug#6170). + 2010-05-30 Stefan Monnier <monnier@iro.umontreal.ca> * .bzrignore: Ignore new files from trunk, which appear if you use
--- a/configure.in Wed Jun 02 00:16:28 2010 +0000 +++ b/configure.in Wed Jun 02 22:44:58 2010 +0000 @@ -3604,15 +3604,19 @@ #ifdef HAVE_STDLIB_H #include <stdlib.h> #endif -#ifndef __GNUC__ -# ifdef HAVE_ALLOCA_H -# include <alloca.h> -# else /* AIX files deal with #pragma. */ -# ifndef alloca /* predefined by HP cc +Olibcalls */ -char *alloca (); -# endif -# endif /* HAVE_ALLOCA_H */ -#endif /* __GNUC__ */ +#ifdef HAVE_ALLOCA_H +# include <alloca.h> +#elif defined __GNUC__ +# define alloca __builtin_alloca +#elif defined _AIX +# define alloca __alloca +#else +# include <stddef.h> +# ifdef __cplusplus +extern "C" +# endif +void *alloca (size_t); +#endif #ifndef HAVE_SIZE_T typedef unsigned size_t; #endif
--- a/lisp/ChangeLog Wed Jun 02 00:16:28 2010 +0000 +++ b/lisp/ChangeLog Wed Jun 02 22:44:58 2010 +0000 @@ -1,3 +1,36 @@ +2010-06-02 Stefan Monnier <monnier@iro.umontreal.ca> + + * emacs-lisp/smie.el (smie-indent-hanging-p): Use smie-bolp. + (smie-indent-calculate): Simplify and cleanup. + +2010-06-02 Michael Albinus <michael.albinus@gmx.de> + + * net/tramp-gvfs.el (top): Require url-util. + (tramp-gvfs-mount-point): Remove. + (tramp-gvfs-stringify-dbus-message, tramp-gvfs-send-command): + New defuns. + (with-tramp-dbus-call-method): Format trace message. + (tramp-gvfs-handle-copy-file, tramp-gvfs-handle-rename-file): + Implement backup call, when operation on local files fails. + Use progress reporter. Flush properties of changed files. + (tramp-gvfs-handle-make-directory): Make more traces. + (tramp-gvfs-url-file-name): Hexify file name in url. + (tramp-gvfs-fuse-file-name): Take also prefix (like dav shares) + into account for the resulting file name. + (tramp-gvfs-handler-askquestion): Return dummy mountpoint, when + the answer is "no". See `tramp-gvfs-maybe-open-connection'. + (tramp-gvfs-handler-mounted-unmounted) + (tramp-gvfs-connection-mounted-p): Test also for new mountspec + attribute "default_location". Set "prefix" property. + (tramp-gvfs-mount-spec): Return both prefix and mountspec. + (tramp-gvfs-maybe-open-connection): Test, whether mountpoint + exists. Raise an error, if not (due to a corresponding answer + "no" in interactive questions, for example). + +22010-06-02 Dan Nicolaescu <dann@ics.uci.edu> + + * log-edit.el (log-edit-font-lock-keywords): Make group 4 match lax. + 2010-06-01 Juanma Barranquero <lekktu@gmail.com> * emacs-lisp/eldoc.el: Add completions for new commands left-* and
--- a/lisp/emacs-lisp/smie.el Wed Jun 02 00:16:28 2010 +0000 +++ b/lisp/emacs-lisp/smie.el Wed Jun 02 22:44:58 2010 +0000 @@ -484,6 +484,14 @@ :type 'integer) (defvar smie-indent-rules 'unset + ;; TODO: For SML, we need more rule formats, so as to handle + ;; structure Foo = + ;; Bar (toto) + ;; and + ;; structure Foo = + ;; struct ... end + ;; I.e. the indentation after "=" depends on the parent ("structure") + ;; as well as on the following token ("struct"). "Rules of the following form. \(TOK OFFSET) how to indent right after TOK. \(TOK O1 O2) how to indent right after TOK: @@ -506,7 +514,7 @@ (forward-char 1)) (skip-chars-forward " \t") (eolp)) - (save-excursion (skip-chars-backward " \t") (not (bolp))))) + (not (smie-bolp)))) (defun smie-bolp () (save-excursion (skip-chars-backward " \t") (bolp))) @@ -526,9 +534,6 @@ to be good only if it follows a line break. - :hanging: means that the current indentation of point can be trusted to be good except if the following token is hanging." - ;; FIXME: This has accumulated a lot of rules, some of which aren't - ;; clearly orthogonal any more, so we should probably try and - ;; restructure it somewhat. (or ;; Trust pre-existing indentation on other lines. (and virtual @@ -598,41 +603,73 @@ (forward-comment (point-max)) (skip-chars-forward " \t\r\n") (smie-indent-calculate nil))) - ;; indentation inside a comment. - ;; FIXME: Hey, this is not generic!! - (and (looking-at "\\*") (nth 4 (syntax-ppss)) + ;; indentation of comment-continue lines. + (and (< 0 (length comment-continue)) + (looking-at (regexp-quote comment-continue)) (nth 4 (syntax-ppss)) (let ((ppss (syntax-ppss))) (save-excursion (forward-line -1) (if (<= (point) (nth 8 ppss)) (progn (goto-char (1+ (nth 8 ppss))) (current-column)) (skip-chars-forward " \t") - (if (looking-at "\\*") + (if (looking-at (regexp-quote comment-continue)) (current-column)))))) ;; Indentation right after a special keyword. (save-excursion (let* ((tok (funcall smie-backward-token-function)) (tokinfo (assoc tok smie-indent-rules)) - (toklevel (assoc tok smie-op-levels))) - (when (or tokinfo (and toklevel (null (cadr toklevel)))) - (if (or (smie-indent-hanging-p) - ;; If calculating the virtual indentation point, prefer - ;; looking up the virtual indentation of the alignment - ;; point as well. This is used for indentation after - ;; "fn x => fn y =>". - virtual) + (toklevel (if (and (zerop (length tok)) + ;; 4 == Open paren syntax. + (eq (syntax-class (syntax-after (1- (point)))) + 4)) + (progn (forward-char -1) + (setq tok (buffer-substring + (point) (1+ (point)))) + (setq tokinfo (assoc tok smie-indent-rules)) + (list tok nil 0)) + (assoc tok smie-op-levels)))) + (if (and toklevel (null (cadr toklevel)) (null tokinfo)) + (setq tokinfo (list (car toklevel) nil nil))) + (if (and tokinfo (null toklevel)) + (error "Token %S has indent rule but has no parsing info" tok)) + (when toklevel + (let ((default-offset + ;; The default indentation after a keyword/operator + ;; is 0 for infix and t for prefix. + ;; Using the BNF syntax, we could come up with + ;; better defaults, but we only have the + ;; precedence levels here. + (if (or tokinfo (null (cadr toklevel))) + (smie-indent-offset t) 0))) + ;; For indentation after "(let", we end up accumulating the + ;; offset of "(" and the offset of "let", so we use `min' + ;; to try and get it right either way. + (min (+ (smie-indent-calculate :bolp) - (or (caddr tokinfo) (cadr tokinfo) (smie-indent-offset t))) + (or (caddr tokinfo) (cadr tokinfo) default-offset)) (+ (current-column) - (or (cadr tokinfo) (smie-indent-offset t))))))) - ;; Main loop (FIXME: whatever that means!?). + (or (cadr tokinfo) default-offset))))))) + ;; Indentation of sequences of simple expressions without + ;; intervening keywords or operators. E.g. "a b c" or "g (balbla) f". + ;; Can be a list of expressions or a function call. + ;; If it's a function call, the first element is special (it's the + ;; function). We distinguish function calls from mere lists of + ;; expressions based on whether the preceding token is listed in + ;; the `list-intro' entry of smie-indent-rules. + ;; + ;; TODO: to indent Lisp code, we should add a way to specify + ;; particular indentation for particular args depending on the + ;; function (which would require always skipping back until the + ;; function). + ;; TODO: to indent C code, such as "if (...) {...}" we might need + ;; to add similar indentation hooks for particular positions, but + ;; based on the preceding token rather than based on the first exp. (save-excursion (let ((positions nil) - (begline nil) arg) (while (and (null (car (smie-backward-sexp))) (push (point) positions) - (not (setq begline (smie-bolp))))) + (not (smie-bolp)))) (save-excursion ;; Figure out if the atom we just skipped is an argument rather ;; than a function. @@ -640,73 +677,28 @@ (member (funcall smie-backward-token-function) (cdr (assoc 'list-intro smie-indent-rules)))))) (cond - ((and arg positions) + ((null positions) + ;; We're the first expression of the list. In that case, the + ;; indentation should be (have been) determined by its context. + nil) + (arg + ;; There's a previous element, and it's not special (it's not + ;; the function), so let's just align with that one. (goto-char (car positions)) (current-column)) - ((and (null begline) (cdr positions)) + ((cdr positions) ;; We skipped some args plus the function and bumped into something. ;; Align with the first arg. (goto-char (cadr positions)) (current-column)) - ((and (null begline) positions) + (positions ;; We're the first arg. - ;; FIXME: it might not be a funcall, in which case we might be the - ;; second element. (goto-char (car positions)) (+ (smie-indent-offset 'args) ;; We used to use (smie-indent-calculate :bolp), but that ;; doesn't seem right since it might then indent args less than ;; the function itself. - (current-column))) - ((and (null arg) (null positions)) - ;; We're the function itself. Not sure what to do here yet. - ;; FIXME: This should not be possible, because it should mean - ;; we're right after some special token. - (if virtual (current-column) - (save-excursion - (let* ((pos (point)) - (tok (funcall smie-backward-token-function)) - (toklevels (cdr (assoc tok smie-op-levels)))) - (cond - ((numberp (car toklevels)) - ;; We're right after an infix token. Let's skip over the - ;; lefthand side. - (goto-char pos) - (let (res) - (while (progn (setq res (smie-backward-sexp 'halfsexp)) - (and (not (smie-bolp)) - (equal (car res) (car toklevels))))) - ;; We should be right after a token of equal or - ;; higher precedence. - (cond - ((and (consp res) (memq (car res) '(t nil))) - ;; The token of higher-precedence is like an open-paren. - ;; Sample case for t: foo { bar, \n[TAB] baz }. - ;; Sample case for nil: match ... with \n[TAB] | toto ... - ;; (goto-char (cadr res)) - (smie-indent-calculate :hanging)) - ((and (consp res) (<= (car res) (car toklevels))) - ;; We stopped at a token of equal or higher precedence - ;; because we found a place with which to align. - (current-column)) - ))) - ;; For other cases.... hmm... we'll see when we get there. - ))))) - ((null positions) - (funcall smie-backward-token-function) - (+ (smie-indent-offset 'args) (smie-indent-calculate :bolp))) - ((car (smie-backward-sexp)) - ;; No arg stands on its own line, but the function does: - (if (cdr positions) - (progn - (goto-char (cadr positions)) - (current-column)) - (goto-char (car positions)) - (+ (current-column) (smie-indent-offset 'args)))) - (t - ;; We've skipped to a previous arg on its own line: align. - (goto-char (car positions)) - (current-column))))))) + (current-column)))))))) (defun smie-indent-line () "Indent current line using the SMIE indentation engine."
--- a/lisp/log-edit.el Wed Jun 02 00:16:28 2010 +0000 +++ b/lisp/log-edit.el Wed Jun 02 22:44:58 2010 +0000 @@ -360,7 +360,7 @@ (3 (or (cdr (assoc (match-string 2) log-edit-headers-alist)) 'log-edit-header) nil lax) - (4 font-lock-warning-face))))) + (4 font-lock-warning-face nil lax))))) ;;;###autoload (defun log-edit (callback &optional setup params buffer mode &rest ignore)
--- a/lisp/net/tramp-gvfs.el Wed Jun 02 00:16:28 2010 +0000 +++ b/lisp/net/tramp-gvfs.el Wed Jun 02 22:44:58 2010 +0000 @@ -28,6 +28,10 @@ ;; incompatibility with the mount_info structure, which has been ;; worked around. +;; It has also been tested with GVFS 1.6.2 (Ubuntu 10.04, Gnome 2.30), +;; where the default_location has been added to mount_info (see +;; <https://bugzilla.gnome.org/show_bug.cgi?id=561998>. + ;; All actions to mount a remote location, and to retrieve mount ;; information, are performed by D-Bus messages. File operations ;; themselves are performed via the mounted filesystem in ~/.gvfs. @@ -100,6 +104,7 @@ (require 'tramp) (require 'dbus) (require 'url-parse) +(require 'url-util) (require 'zeroconf) (defcustom tramp-gvfs-methods '("dav" "davs" "obex" "synce") @@ -133,10 +138,6 @@ (unless (assoc elt tramp-methods) (add-to-list 'tramp-methods (cons elt nil)))))) -(defconst tramp-gvfs-mount-point - (file-name-as-directory (expand-file-name ".gvfs" "~/")) - "The directory name, fuses mounts remote ressources.") - (defconst tramp-gvfs-path-tramp (concat dbus-path-emacs "/Tramp") "The preceeding object path for own objects.") @@ -190,6 +191,7 @@ ;; STRUCT mount_spec_item ;; STRING key (server, share, type, user, host, port) ;; ARRAY BYTE value +;; STRING default_location Since GVFS 1.5 only !!! (defconst tramp-gvfs-interface-mountoperation "org.gtk.vfs.MountOperation" "Used by the dbus-proxying implementation of GMountOperation.") @@ -449,6 +451,17 @@ (add-to-list 'tramp-foreign-file-name-handler-alist (cons 'tramp-gvfs-file-name-p 'tramp-gvfs-file-name-handler)) +(defun tramp-gvfs-stringify-dbus-message (message) + "Convert a D-Bus message into readable UTF8 strings, used for traces." + (cond + ((and (consp message) (characterp (car message))) + (format "%S" (dbus-byte-array-to-string message))) + ((consp message) + (mapcar 'tramp-gvfs-stringify-dbus-message message)) + ((stringp message) + (format "%S" message)) + (t message))) + (defmacro with-tramp-dbus-call-method (vec synchronous bus service path interface method &rest args) "Apply a D-Bus call on bus BUS. @@ -466,7 +479,7 @@ result) (tramp-message ,vec 6 "%s %s" func args) (setq result (apply func args)) - (tramp-message ,vec 6 "\n%s" result) + (tramp-message ,vec 6 "%s" (tramp-gvfs-stringify-dbus-message result)) result)) (put 'with-tramp-dbus-call-method 'lisp-indent-function 2) @@ -480,7 +493,7 @@ `(let ((fuse-file-name (regexp-quote (tramp-gvfs-fuse-file-name ,filename))) elt) (condition-case err - (apply ,handler (list ,@args)) + (funcall ,handler ,@args) (error (setq elt (cdr err)) (while elt @@ -515,18 +528,41 @@ (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid preserve-selinux-context) "Like `copy-file' for Tramp files." - (let ((args - (list - (if (tramp-gvfs-file-name-p filename) - (tramp-gvfs-fuse-file-name filename) - filename) - (if (tramp-gvfs-file-name-p newname) - (tramp-gvfs-fuse-file-name newname) - newname) - ok-if-already-exists keep-date preserve-uid-gid))) - (when preserve-selinux-context - (setq args (append args (list preserve-selinux-context)))) - (apply 'copy-file args))) + (with-parsed-tramp-file-name + (if (tramp-tramp-file-p filename) filename newname) nil + (with-progress-reporter + v 0 (format "Copying %s to %s" filename newname) + (condition-case err + (let ((args + (list + (if (tramp-gvfs-file-name-p filename) + (tramp-gvfs-fuse-file-name filename) + filename) + (if (tramp-gvfs-file-name-p newname) + (tramp-gvfs-fuse-file-name newname) + newname) + ok-if-already-exists keep-date preserve-uid-gid))) + (when preserve-selinux-context + (setq args (append args (list preserve-selinux-context)))) + (apply 'copy-file args)) + + ;; Error case. Let's try it with the GVFS utilities. + (error + (tramp-message v 4 "`copy-file' failed, trying `gvfs-copy'") + (unless + (zerop + (tramp-gvfs-send-command + v "gvfs-copy" + (if (or keep-date preserve-uid-gid) "--preserve" "") + (tramp-gvfs-url-file-name filename) + (tramp-gvfs-url-file-name newname))) + ;; Propagate the error. + (tramp-error v (car err) "%s" (cdr err))))))) + + (when (file-remote-p newname) + (with-parsed-tramp-file-name newname nil + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-file-property v localname)))) (defun tramp-gvfs-handle-delete-directory (directory &optional recursive) "Like `delete-directory' for Tramp files." @@ -657,19 +693,20 @@ (defun tramp-gvfs-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." - (condition-case err - (with-tramp-gvfs-error-message dir 'make-directory - (tramp-gvfs-fuse-file-name dir) parents) - ;; Error case. Let's try it with the GVFS utilities. - (error - (with-parsed-tramp-file-name dir nil + (with-parsed-tramp-file-name dir nil + (condition-case err + (with-tramp-gvfs-error-message dir 'make-directory + (tramp-gvfs-fuse-file-name dir) parents) + + ;; Error case. Let's try it with the GVFS utilities. + (error (tramp-message v 4 "`make-directory' failed, trying `gvfs-mkdir'") (unless (zerop - (tramp-local-call-process - "gvfs-mkdir" nil (tramp-get-buffer v) nil - (tramp-gvfs-url-file-name dir))) - (signal (car err) (cdr err))))))) + (tramp-gvfs-send-command + v "gvfs-mkdir" (tramp-gvfs-url-file-name dir))) + ;; Propagate the error. + (tramp-error v (car err) "%s" (cdr err))))))) (defun tramp-gvfs-handle-process-file (program &optional infile destination display &rest args) @@ -680,14 +717,41 @@ (defun tramp-gvfs-handle-rename-file (filename newname &optional ok-if-already-exists) "Like `rename-file' for Tramp files." - (rename-file - (if (tramp-gvfs-file-name-p filename) - (tramp-gvfs-fuse-file-name filename) - filename) - (if (tramp-gvfs-file-name-p newname) - (tramp-gvfs-fuse-file-name newname) - newname) - ok-if-already-exists)) + (with-parsed-tramp-file-name + (if (tramp-tramp-file-p filename) filename newname) nil + (with-progress-reporter + v 0 (format "Renaming %s to %s" filename newname) + (condition-case err + (rename-file + (if (tramp-gvfs-file-name-p filename) + (tramp-gvfs-fuse-file-name filename) + filename) + (if (tramp-gvfs-file-name-p newname) + (tramp-gvfs-fuse-file-name newname) + newname) + ok-if-already-exists) + + ;; Error case. Let's try it with the GVFS utilities. + (error + (tramp-message v 4 "`rename-file' failed, trying `gvfs-move'") + (unless + (zerop + (tramp-gvfs-send-command + v "gvfs-move" + (tramp-gvfs-url-file-name filename) + (tramp-gvfs-url-file-name newname))) + ;; Propagate the error. + (tramp-error v (car err) "%s" (cdr err))))))) + + (when (file-remote-p filename) + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-file-property v localname))) + + (when (file-remote-p newname) + (with-parsed-tramp-file-name newname nil + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-file-property v localname)))) (defun tramp-gvfs-handle-set-file-modes (filename mode) "Like `set-file-modes' for Tramp files." @@ -730,19 +794,16 @@ start end (tramp-gvfs-fuse-file-name filename) append visit lockname confirm) - ;; Error case. Let's try it with the GVFS utilities. + ;; Error case. Let's try rename. (error (let ((tmpfile (tramp-compat-make-temp-file filename))) - (tramp-message v 4 "`write-region' failed, trying `gvfs-save'") + (tramp-message v 4 "`write-region' failed, trying `rename-file'") (write-region start end tmpfile) - (unwind-protect - (unless - (zerop - (tramp-local-call-process - "gvfs-save" tmpfile (tramp-get-buffer v) nil - (tramp-gvfs-url-file-name filename))) - (signal (car err) (cdr err))) - (delete-file tmpfile))))) + (condition-case nil + (rename-file tmpfile filename) + (error + (delete-file tmpfile) + (tramp-error v (car err) "%s" (cdr err))))))) ;; Set file modification time. (when (or (eq visit t) (stringp visit)) @@ -758,16 +819,20 @@ (defun tramp-gvfs-url-file-name (filename) "Return FILENAME in URL syntax." - (url-recreate-url - (if (tramp-tramp-file-p filename) - (with-parsed-tramp-file-name (file-truename filename) nil - (when (string-match tramp-user-with-domain-regexp user) - (setq user - (concat (match-string 2 user) ";" (match-string 2 user)))) - (url-parse-make-urlobj - method user nil - (tramp-file-name-real-host v) (tramp-file-name-port v) localname)) - (url-parse-make-urlobj "file" nil nil nil nil (file-truename filename))))) + ;; "/" must NOT be hexlified. + (let ((url-unreserved-chars (append '(?/) url-unreserved-chars))) + (url-recreate-url + (if (tramp-tramp-file-p filename) + (with-parsed-tramp-file-name (file-truename filename) nil + (when (string-match tramp-user-with-domain-regexp user) + (setq user + (concat (match-string 2 user) ";" (match-string 2 user)))) + (url-parse-make-urlobj + method user nil + (tramp-file-name-real-host v) (tramp-file-name-port v) + (url-hexify-string localname))) + (url-parse-make-urlobj + "file" nil nil nil nil (url-hexify-string (file-truename filename))))))) (defun tramp-gvfs-object-path (filename) "Create a D-Bus object path from FILENAME." @@ -782,15 +847,19 @@ "Return FUSE file name, which is directly accessible." (with-parsed-tramp-file-name (expand-file-name filename) nil (tramp-gvfs-maybe-open-connection v) - (let ((fuse-mountpoint + (let ((prefix (tramp-get-file-property v "/" "prefix" "")) + (fuse-mountpoint (tramp-get-file-property v "/" "fuse-mountpoint" nil))) (unless fuse-mountpoint (tramp-error v 'file-error "There is no FUSE mount point for `%s'" filename)) - ;; We must remove the share from the local name. - (when (and (string-equal "smb" method) (string-match "/[^/]+" localname)) + ;; We must hide the prefix, if any. + (when (string-match (concat "^" (regexp-quote prefix)) localname) (setq localname (replace-match "" t t localname))) - (concat tramp-gvfs-mount-point fuse-mountpoint localname)))) + (tramp-message + v 10 "remote file `%s' is local file `%s'" + filename (concat fuse-mountpoint localname)) + (concat fuse-mountpoint localname)))) (defun tramp-bluez-address (device) "Return bluetooth device address from a given bluetooth DEVICE name." @@ -881,10 +950,10 @@ (setq choice (if (yes-or-no-p (concat (car choices) " ")) 0 1)) (tramp-message v 6 "%d" choice))) - ;; When the choice is "no", we set an empty - ;; fuse-mountpoint in order to leave the timeout. + ;; When the choice is "no", we set a dummy fuse-mountpoint + ;; in order to leave the timeout. (unless (zerop choice) - (tramp-set-file-property v "/" "fuse-mountpoint" "")) + (tramp-set-file-property v "/" "fuse-mountpoint" "/")) (list t ;; handled. @@ -898,6 +967,10 @@ "Signal handler for the \"org.gtk.vfs.MountTracker.mounted\" and \"org.gtk.vfs.MountTracker.unmounted\" signals." (ignore-errors + ;; The last element could be the default location in newer gvfs + ;; versions. We must check this. + (unless (consp (car (last mount-info))) + (setq mount-info (butlast mount-info))) (let* ((signal-name (dbus-event-member-name last-input-event)) (mount-spec (cadar (last mount-info))) (method (dbus-byte-array-to-string (cadr (assoc "type" mount-spec)))) @@ -908,7 +981,10 @@ (cadr (or (assoc "host" mount-spec) (assoc "server" mount-spec))))) (port (dbus-byte-array-to-string (cadr (assoc "port" mount-spec)))) - (ssl (dbus-byte-array-to-string (cadr (assoc "ssl" mount-spec))))) + (ssl (dbus-byte-array-to-string (cadr (assoc "ssl" mount-spec)))) + (prefix (concat (dbus-byte-array-to-string (caar (last mount-info))) + (dbus-byte-array-to-string + (cadr (assoc "share" mount-spec)))))) (when (string-match "^smb" method) (setq method "smb")) (when (string-equal "obex" method) @@ -921,14 +997,17 @@ (setq host (concat host tramp-prefix-port-format port))) (with-parsed-tramp-file-name (tramp-make-tramp-file-name method user host "") nil - (tramp-message v 6 "%s %s" signal-name mount-info) + (tramp-message + v 6 "%s %s" signal-name (tramp-gvfs-stringify-dbus-message mount-info)) (tramp-set-file-property v "/" "list-mounts" 'undef) (if (string-equal signal-name "unmounted") (tramp-set-file-property v "/" "fuse-mountpoint" nil) + ;; Set prefix and mountpoint. + (unless (string-equal prefix "/") + (tramp-set-file-property v "/" "prefix" prefix)) (tramp-set-file-property v "/" "fuse-mountpoint" - (file-name-nondirectory - (dbus-byte-array-to-string (car (last mount-info 2)))))))))) + (dbus-byte-array-to-string (car (last mount-info 2))))))))) (dbus-register-signal :session nil tramp-gvfs-path-mounttracker @@ -942,47 +1021,60 @@ (defun tramp-gvfs-connection-mounted-p (vec) "Check, whether the location is already mounted." - (catch 'mounted - (dolist - (elt - (with-file-property vec "/" "list-mounts" - (with-tramp-dbus-call-method vec t - :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker - tramp-gvfs-interface-mounttracker "listMounts")) - nil) - (let* ((mount-spec (cadar (last elt))) - (method (dbus-byte-array-to-string - (cadr (assoc "type" mount-spec)))) - (user (dbus-byte-array-to-string - (cadr (assoc "user" mount-spec)))) - (domain (dbus-byte-array-to-string - (cadr (assoc "domain" mount-spec)))) - (host (dbus-byte-array-to-string - (cadr (or (assoc "host" mount-spec) - (assoc "server" mount-spec))))) - (port (dbus-byte-array-to-string (cadr (assoc "port" mount-spec)))) - (ssl (dbus-byte-array-to-string (cadr (assoc "ssl" mount-spec))))) - (when (string-match "^smb" method) - (setq method "smb")) - (when (string-equal "obex" method) - (setq host (tramp-bluez-device host))) - (when (and (string-equal "dav" method) (string-equal "true" ssl)) - (setq method "davs")) - (when (and (string-equal "synce" method) (zerop (length user))) - (setq user (or (tramp-file-name-user vec) ""))) - (unless (zerop (length domain)) - (setq user (concat user tramp-prefix-domain-format domain))) - (unless (zerop (length port)) - (setq host (concat host tramp-prefix-port-format port))) - (when (and - (string-equal method (tramp-file-name-method vec)) - (string-equal user (or (tramp-file-name-user vec) "")) - (string-equal host (tramp-file-name-host vec))) - (tramp-set-file-property - vec "/" "fuse-mountpoint" - (file-name-nondirectory - (dbus-byte-array-to-string (car (last elt 2))))) - (throw 'mounted t)))))) + (or + (tramp-get-file-property vec "/" "fuse-mountpoint" nil) + (catch 'mounted + (dolist + (elt + (with-file-property vec "/" "list-mounts" + (with-tramp-dbus-call-method vec t + :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker + tramp-gvfs-interface-mounttracker "listMounts")) + nil) + ;; The last element could be the default location in newer gvfs + ;; versions. We must check this. + (unless (consp (car (last elt))) (setq elt (butlast elt))) + (let* ((mount-spec (cadar (last elt))) + (method (dbus-byte-array-to-string + (cadr (assoc "type" mount-spec)))) + (user (dbus-byte-array-to-string + (cadr (assoc "user" mount-spec)))) + (domain (dbus-byte-array-to-string + (cadr (assoc "domain" mount-spec)))) + (host (dbus-byte-array-to-string + (cadr (or (assoc "host" mount-spec) + (assoc "server" mount-spec))))) + (port (dbus-byte-array-to-string + (cadr (assoc "port" mount-spec)))) + (ssl (dbus-byte-array-to-string (cadr (assoc "ssl" mount-spec)))) + (prefix (concat (dbus-byte-array-to-string (caar (last elt))) + (dbus-byte-array-to-string + (cadr (assoc "share" mount-spec)))))) + (when (string-match "^smb" method) + (setq method "smb")) + (when (string-equal "obex" method) + (setq host (tramp-bluez-device host))) + (when (and (string-equal "dav" method) (string-equal "true" ssl)) + (setq method "davs")) + (when (and (string-equal "synce" method) (zerop (length user))) + (setq user (or (tramp-file-name-user vec) ""))) + (unless (zerop (length domain)) + (setq user (concat user tramp-prefix-domain-format domain))) + (unless (zerop (length port)) + (setq host (concat host tramp-prefix-port-format port))) + (when (and + (string-equal method (tramp-file-name-method vec)) + (string-equal user (or (tramp-file-name-user vec) "")) + (string-equal host (tramp-file-name-host vec)) + (string-match (concat "^" (regexp-quote prefix)) + (tramp-file-name-localname vec))) + ;; Set prefix and mountpoint. + (unless (string-equal prefix "/") + (tramp-set-file-property vec "/" "prefix" prefix)) + (tramp-set-file-property + vec "/" "fuse-mountpoint" + (dbus-byte-array-to-string (car (last elt 2)))) + (throw 'mounted t))))))) (defun tramp-gvfs-mount-spec (vec) "Return a mount-spec for \"org.gtk.vfs.MountTracker.mountLocation\"." @@ -993,7 +1085,8 @@ (port (tramp-file-name-port vec)) (localname (tramp-file-name-localname vec)) (ssl (if (string-match "^davs" method) "true" "false")) - (mount-spec `(:array))) + (mount-spec '(:array)) + (mount-pref "/")) (setq mount-spec @@ -1036,8 +1129,12 @@ `(:struct "port" ,(dbus-string-to-byte-array (number-to-string port))) 'append)) + (when (and (string-match "^dav" method) + (string-match "^/?[^/]+" localname)) + (setq mount-pref (match-string 0 localname))) + ;; Return. - mount-spec)) + `(:struct ,(dbus-string-to-byte-array mount-pref) ,mount-spec))) ;; Connection functions @@ -1096,10 +1193,7 @@ (with-tramp-dbus-call-method vec nil :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker tramp-gvfs-interface-mounttracker "mountLocation" - `(:struct - ,(dbus-string-to-byte-array "/") - ,(tramp-gvfs-mount-spec vec)) - (dbus-get-unique-name :session) + (tramp-gvfs-mount-spec vec) (dbus-get-unique-name :session) :object-path object-path) ;; We must wait, until the mount is applied. This will be @@ -1117,11 +1211,29 @@ (while (not (tramp-get-file-property vec "/" "fuse-mountpoint" nil)) (read-event nil nil 0.1))) + ;; If `tramp-gvfs-handler-askquestion' has returned "No", it + ;; is marked with the fuse-mountpoint "/". We shall react. + (when (string-equal + (tramp-get-file-property vec "/" "fuse-mountpoint" "") "/") + (tramp-error vec 'file-error "FUSE mount denied")) + ;; We set the connection property "started" in order to put the ;; remote location into the cache, which is helpful for further ;; completion. (tramp-set-connection-property vec "started" t))))) +(defun tramp-gvfs-send-command (vec command &rest args) + "Send the COMMAND with its ARGS to connection VEC. +COMMAND is usually a command from the gvfs-* utilities. +`call-process' is applied, and its return code is returned." + (let (result) + (with-current-buffer (tramp-get-buffer vec) + (erase-buffer) + (tramp-message vec 6 "%s %s" command (mapconcat 'identity args " ")) + (setq result (apply 'tramp-local-call-process command nil t nil args)) + (tramp-message vec 6 "%s" (buffer-string)) + result))) + ;; D-Bus BLUEZ functions.
--- a/src/ChangeLog Wed Jun 02 00:16:28 2010 +0000 +++ b/src/ChangeLog Wed Jun 02 22:44:58 2010 +0000 @@ -1,3 +1,24 @@ +2010-06-02 Dan Nicolaescu <dann@ics.uci.edu> + + Fix config.h includes. + * xsettings.c: + * xgselect.c: + * nsterm.m: + * nsselect.m: + * nsimage.m: + * nsfont.m: + * nsfns.m: + * dbusbind.c: Use #include <config.h> instead of "config.h" as all + other files do. + + * gmalloc.c: Remove BROKEN_PROTOTYPES reference, unused. + + * s/sol2-6.h: Remove obsolete comments. + + Remove unnecessary alloca.h includes. + * keymap.c: Do not include alloca.h, config.h does that. + * sysdep.c: Likewise. Do not define fwrite, not used. + 2010-06-01 Stefan Monnier <monnier@iro.umontreal.ca> * sysdep.c (child_setup_tty): Move the non-canonical initialization to
--- a/src/config.in Wed Jun 02 00:16:28 2010 +0000 +++ b/src/config.in Wed Jun 02 22:44:58 2010 +0000 @@ -1164,15 +1164,19 @@ #ifdef HAVE_STDLIB_H #include <stdlib.h> #endif -#ifndef __GNUC__ -# ifdef HAVE_ALLOCA_H -# include <alloca.h> -# else /* AIX files deal with #pragma. */ -# ifndef alloca /* predefined by HP cc +Olibcalls */ -char *alloca (); -# endif -# endif /* HAVE_ALLOCA_H */ -#endif /* __GNUC__ */ +#ifdef HAVE_ALLOCA_H +# include <alloca.h> +#elif defined __GNUC__ +# define alloca __builtin_alloca +#elif defined _AIX +# define alloca __alloca +#else +# include <stddef.h> +# ifdef __cplusplus +extern "C" +# endif +void *alloca (size_t); +#endif #ifndef HAVE_SIZE_T typedef unsigned size_t; #endif
--- a/src/dbusbind.c Wed Jun 02 00:16:28 2010 +0000 +++ b/src/dbusbind.c Wed Jun 02 22:44:58 2010 +0000 @@ -16,7 +16,7 @@ You should have received a copy of the GNU General Public License along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ -#include "config.h" +#include <config.h> #ifdef HAVE_DBUS #include <stdlib.h>
--- a/src/gmalloc.c Wed Jun 02 00:16:28 2010 +0000 +++ b/src/gmalloc.c Wed Jun 02 22:44:58 2010 +0000 @@ -42,8 +42,7 @@ #endif #if ((defined __cplusplus || (defined (__STDC__) && __STDC__) \ - || defined STDC_HEADERS || defined PROTOTYPES) \ - && ! defined (BROKEN_PROTOTYPES)) + || defined STDC_HEADERS || defined PROTOTYPES)) #undef PP #define PP(args) args #undef __ptr_t
--- a/src/keymap.c Wed Jun 02 00:16:28 2010 +0000 +++ b/src/keymap.c Wed Jun 02 22:44:58 2010 +0000 @@ -22,9 +22,6 @@ #include <config.h> #include <stdio.h> #include <setjmp.h> -#if HAVE_ALLOCA_H -# include <alloca.h> -#endif #include "lisp.h" #include "commands.h" #include "buffer.h"
--- a/src/nsfns.m Wed Jun 02 00:16:28 2010 +0000 +++ b/src/nsfns.m Wed Jun 02 22:44:58 2010 +0000 @@ -27,7 +27,7 @@ /* This should be the first include, as it may set up #defines affecting interpretation of even the system includes. */ -#include "config.h" +#include <config.h> #include <signal.h> #include <math.h>
--- a/src/nsfont.m Wed Jun 02 00:16:28 2010 +0000 +++ b/src/nsfont.m Wed Jun 02 22:44:58 2010 +0000 @@ -22,7 +22,7 @@ /* This should be the first include, as it may set up #defines affecting interpretation of even the system includes. */ -#include "config.h" +#include <config.h> #include <setjmp.h> #include "lisp.h"
--- a/src/nsimage.m Wed Jun 02 00:16:28 2010 +0000 +++ b/src/nsimage.m Wed Jun 02 22:44:58 2010 +0000 @@ -27,7 +27,7 @@ /* This should be the first include, as it may set up #defines affecting interpretation of even the system includes. */ -#include "config.h" +#include <config.h> #include <setjmp.h> #include "lisp.h"
--- a/src/nsselect.m Wed Jun 02 00:16:28 2010 +0000 +++ b/src/nsselect.m Wed Jun 02 22:44:58 2010 +0000 @@ -27,7 +27,7 @@ /* This should be the first include, as it may set up #defines affecting interpretation of even the system includes. */ -#include "config.h" +#include <config.h> #include <setjmp.h> #include "lisp.h"
--- a/src/nsterm.m Wed Jun 02 00:16:28 2010 +0000 +++ b/src/nsterm.m Wed Jun 02 22:44:58 2010 +0000 @@ -27,7 +27,7 @@ /* This should be the first include, as it may set up #defines affecting interpretation of even the system includes. */ -#include "config.h" +#include <config.h> #include <math.h> #include <sys/types.h>
--- a/src/s/sol2-6.h Wed Jun 02 00:16:28 2010 +0000 +++ b/src/s/sol2-6.h Wed Jun 02 22:44:58 2010 +0000 @@ -63,18 +63,6 @@ pty_name[sizeof (pty_name) - 1] = 0; \ } -/* This is the only known way to avoid some crashes - that seem to relate to screwed up malloc data - after deleting a frame. */ -/* rms: I think the problems using ralloc had to do with system - libraries that called the system malloc even if we linked in the - GNU malloc. I could not see any way to fix the problem except to - have just one malloc and that had to be the system one. */ -/* This is not always necessary. Turned off at present for testers to - identify any problems with gmalloc more accurately. */ -/* #define SYSTEM_MALLOC */ - -/* Probably OK also on earlier versions. */ #define GC_SETJMP_WORKS 1 #define GC_MARK_STACK GC_MAKE_GCPROS_NOOPS
--- a/src/sysdep.c Wed Jun 02 00:16:28 2010 +0000 +++ b/src/sysdep.c Wed Jun 02 22:44:58 2010 +0000 @@ -36,9 +36,6 @@ #ifdef HAVE_UNISTD_H #include <unistd.h> #endif -#ifdef HAVE_ALLOCA_H -#include <alloca.h> -#endif /* HAVE_ALLOCA_H */ #include "lisp.h" /* Including stdlib.h isn't necessarily enough to get srandom @@ -61,13 +58,6 @@ #endif #endif /* not WINDOWSNT */ -/* Does anyone other than VMS need this? */ -#ifndef fwrite -#define sys_fwrite fwrite -#else -#undef fwrite -#endif - #include <sys/types.h> #include <sys/stat.h> #include <errno.h>
--- a/src/xgselect.c Wed Jun 02 00:16:28 2010 +0000 +++ b/src/xgselect.c Wed Jun 02 22:44:58 2010 +0000 @@ -17,7 +17,7 @@ You should have received a copy of the GNU General Public License along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ -#include "config.h" +#include <config.h> #if defined (USE_GTK) || defined (HAVE_GCONF) #include <glib.h>
--- a/src/xsettings.c Wed Jun 02 00:16:28 2010 +0000 +++ b/src/xsettings.c Wed Jun 02 22:44:58 2010 +0000 @@ -17,7 +17,7 @@ You should have received a copy of the GNU General Public License along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ -#include "config.h" +#include <config.h> #include <limits.h> #include <setjmp.h> #include <fcntl.h>
--- a/test/ChangeLog Wed Jun 02 00:16:28 2010 +0000 +++ b/test/ChangeLog Wed Jun 02 22:44:58 2010 +0000 @@ -1,3 +1,7 @@ +2010-06-02 Stefan Monnier <monnier@iro.umontreal.ca> + + * indent: New dir. + 2010-05-07 Chong Yidong <cyd@stupidchicken.com> * Version 23.2 released.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/test/indent/Makefile Wed Jun 02 22:44:58 2010 +0000 @@ -0,0 +1,15 @@ +RM=rm +EMACS=emacs + +clean: + -$(RM) *.test + +# TODO: +# - mark the places where the indentation is known to be incorrect, +# and allow either ignoring those errors or not. +%.test: % + -$(RM) $<.test + $(EMACS) --batch $< \ + --eval '(indent-region (point-min) (point-max) nil)' \ + --eval '(write-region (point-min) (point-max) "$<.test")' + diff -u -B $< $<.test
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/test/indent/prolog.prolog Wed Jun 02 22:44:58 2010 +0000 @@ -0,0 +1,224 @@ +%% -*- mode: prolog; coding: utf-8 -*- + +%% wf(+E) +%% Vérifie que E est une expression syntaxiquement correcte. +wf(X) :- atom(X); integer(X); var(X). %Une variable ou un entier. +wf(lambda(X, T, B)) :- atom(X), wf(T), wf(B). %Une fonction. +wf(app(E1, E2)) :- wf(E1), wf(E2). %Un appel de fonction. +wf(pi(X, T, B)) :- atom(X), wf(T), wf(B). %Le type d'une fonction. + +%% Éléments additionnels utilisés dans le langage source. +wf(lambda(X, B)) :- atom(X), wf(B). +wf(let(X, E1, E2)) :- atom(X), wf(E1), wf(E2). +wf(let(X, T, E1, E2)) :- atom(X), wf(T), wf(E1), wf(E2). +wf((T1 -> T2)) :- wf(T1), wf(T2). +wf(forall(X, T, B)) :- atom(X), wf(T), wf(B). +wf(fix(X,T,E1,E2)) :- atom(X), wf(T), wf(E1), wf(E2). +wf(fix(X,E1,E2)) :- atom(X), wf(E1), wf(E2). +wf(app(E1,E2,E3)) :- wf(E1), wf(E2), wf(E3). +wf(app(E1,E2,E3,E4)) :- wf(E1), wf(E2), wf(E3), wf(E4). + +%% subst(+X, +V, +FV, +Ei, -Eo) +%% Remplace X par V dans Ei. Les variables qui apparaissent libres dans +%% V et peuvent aussi apparaître dans Ei doivent toutes être inclues +%% dans l'environnement FV. +subst(X, V, _, X, E) :- !, E = V. +subst(_, _, _, Y, Y) :- atom(Y); integer(Y). +%% Residualize the substitution when applied to an uninstantiated variable. +%% subst(X, V, _, Y, app(lambda(X,_,Y),V)) :- var(Y). +%% Rather than residualize and leave us with unifications that fail, let's +%% rather assume that Y will not refer to X. +subst(X, V, _, Y, Y) :- var(Y). +subst(X, V, FV, lambda(Y, Ti, Bi), lambda(Y1, To, Bo)) :- + subst(X, V, FV, Ti, To), + (X = Y -> + %% If X is equal to Y, X is shadowed, so no subst can take place. + Y1 = Y, Bo = Bi; + (member((Y, _), FV) -> + %% If Y appears in FV, it can appear in V, so we need to + %% rename it to avoid name capture. + new_atom(Y, Y1), + subst(Y, Y1, [], Bi, Bi1); + Y1 = Y, Bi1 = Bi), + %% Perform substitution on the body. + subst(X, V, FV, Bi1, Bo)). +subst(X, V, FV, pi(Y, Ti, Bi), pi(Y1, To, Bo)) :- + subst(X, V, FV, lambda(Y, Ti, Bi), lambda(Y1, To, Bo)). +subst(X, V, FV, forall(Y, Ti, Bi), forall(Y1, To, Bo)) :- + subst(X, V, FV, lambda(Y, Ti, Bi), lambda(Y1, To, Bo)). +subst(X, V, FV, app(E1i, E2i), app(E1o, E2o)) :- + subst(X, V, FV, E1i, E1o), subst(X, V, FV, E2i, E2o). + +%% apply(+F, +Arg, +Env, -E) +apply(lambda(X, _, B), Arg, Env, E) :- \+ var(B), subst(X, Arg, Env, B, E). +apply(app(plus, N1), N2, _, N) :- integer(N1), integer(N2), N is N1 + N2. +apply(app(minus, N1), N2, _, N) :- integer(N1), integer(N2), N is N1 - N2. + + +%% normalize(+E1, +Env, -E2) +%% Applique toutes les réductions possibles sur E1. +normalize(X, _, X) :- integer(X); var(X); atom(X). +%% normalize(X, Env, E) :- atom(X), member((X, E), Env). +normalize(lambda(X, T, B), Env, lambda(X, Tn, Bn)) :- + normalize(T, [(X,T)|Env], Tn), normalize(B, [(X,T)|Env], Bn). +normalize(pi(X, T, B), Env, pi(X, Tn, Bn)) :- + normalize(T, [(X,T)|Env], Tn), normalize(B, [(X,T)|Env], Bn). +normalize(forall(X, T, B), Env, forall(X, Tn, Bn)) :- + normalize(T, [(X,T)|Env], Tn), normalize(B, [(X,T)|Env], Bn). +normalize(app(E1, E2), Env, En) :- + normalize(E1, Env, E1n), + normalize(E2, Env, E2n), + (apply(E1n, E2n, Env, E) -> + normalize(E, Env, En); + En = app(E1n, E2n)). + +%% infer(+E, +Env, -T) +%% Infère le type de E dans Env. On essaie d'être permissif, dans le sens +%% que l'on présume que l'expression est typée correctement. +infer(X, _, int) :- integer(X). +infer(X, _, _) :- var(X). %Une expression encore inconnue. +infer(X, Env, T) :- + atom(X), + (member((X, T1), Env) -> + %% X est déjà dans Env: vérifie que le type est correct. + T = T1; + %% X est une variable libre. + true). +infer(lambda(X,T,B), Env, pi(Y,T,TB)) :- + infer(B, [(X,T)|Env], TBx), + (var(Y) -> + Y = X, TB = TBx; + subst(X, Y, Env, TBx, TB)). +infer(app(E1, E2), Env, Tn) :- + infer(E1, Env, T1), + (T1 = pi(X,T2,B); T1 = forall(X,T2,B)), + infer(E2, Env, T2), + subst(X, E2, Env, B, T), + normalize(T, Env, Tn). +infer(pi(X,T1,T2), Env, type) :- + infer(T1, Env, type), + infer(T2, [(X,T1)|Env], type). +infer(forall(X,T1,T2), Env, type) :- + infer(T1, Env, type), + infer(T2, [(X,T1)|Env], type). + +%% freevars(+E, +Env, -Vs) +%% Renvoie les variables libres de E. Vs est une liste associative +%% où chaque élément est de la forme (X,T) où X est une variable et T est +%% son type. +freevars(X, _, []) :- integer(X). +freevars(X, Env, Vs) :- + atom(X), + (member((X,_), Env) -> + %% Variable liée. + Vs = []; + %% Variable libre. Type inconnu :-( + Vs = [(X,_)]). +%% Les variables non-instanciées peuvent être remplacées par des paramètres +%% qui seront liés par `closetype' selon le principe de Hindley-Milner. +freevars(X, _, [(X, _)]) :- var(X), new_atom(X). +freevars(app(E1, E2), Env, Vs) :- + freevars(E1, Env, Vs1), + append(Vs1, Env, Env1), + freevars(E2, Env1, Vs2), + append(Vs1, Vs2, Vs). +freevars(lambda(X, T, B), Env, Vs) :- + freevars(T, Env, TVs), + append(TVs, Env, Env1), + freevars(B, [(X,T)|Env1], BVs), + append(TVs, BVs, Vs). +freevars(pi(X, T, B), Env, Vs) :- freevars(lambda(X, T, B), Env, Vs). +freevars(forall(X, T, B), Env, Vs) :- freevars(lambda(X, T, B), Env, Vs). + +%% close(+Eo, +To, +Vs, -Ec, -Tc) +%% Ferme un type ouvert To en liant chaque variable libre (listées dans Vs) +%% avec `forall'. +closetype(E, T, [], E, T). +closetype(Eo, To, [(X,T)|Vs], lambda(X, T, Ec), forall(X, T, Tc)) :- + closetype(Eo, To, Vs, Ec, Tc). + +%% elab_type(+Ee, +Te, +Env, -Eg, -Tg) +%% Ajoute les arguments implicites de E:T. +generalize(Ee, Te, Env, Eg, Tg) :- + freevars(Te, Env, Vs), + append(Vs, Env, EnvX), + %% Essaie d'instancier les types des paramètres que `generalize' vient + %% d'ajouter. + infer(Te, EnvX, type), + closetype(Ee, Te, Vs, Eg, Tg). + +%% instantiate(+X, +T, -E) +%% Utilise la variable X de type T. Le résultat E est X auquel on ajoute +%% tous les arguments implicites (de valeur inconnue). +instantiate(X, T, X) :- var(T), ! . +instantiate(X, forall(_, _, T), app(E, _)) :- !, instantiate(X, T, E). +instantiate(X, _, X). + +%% elaborate(+E1, +Env, -E2) +%% Transforme E1 en une expression E2 où le sucre syntaxique a été éliminé +%% et où les arguments implicites ont été rendus explicites. +elaborate(X, _, X) :- integer(X); var(X). +elaborate(X, Env, E) :- + atom(X), + (member((X, T), Env) -> + instantiate(X, T, E); + %% Si X n'est pas dans l'environnement, c'est une variable libre que + %% l'on voudra probablement généraliser. + X = E). +elaborate(lambda(X, T, B), Env, lambda(X, Te, Be)) :- + elaborate(T, Env, Te), + elaborate(B, [(X,Te)|Env], Be). +elaborate(pi(X, T, B), Env, pi(X, Te, Be)) :- + elaborate(T, Env, Te), + elaborate(B, [(X,Te)|Env], Be). +elaborate(app(E1, E2), Env, app(E1e, E2e)) :- + elaborate(E1, Env, E1e), + elaborate(E2, Env, E2e). +elaborate(let(X, T, E1, E2), Env, app(lambda(X, Tg, E2e), E1g)) :- + elaborate(E1, Env, E1e), + elaborate(T, Env, Te), + infer(E1e, Env, Te), + generalize(E1e, Te, Env, E1g, Tg), + elaborate(E2, [(X,Te)|Env], E2e). +%% Expansion du sucre syntaxique. +elaborate((T1 -> T2), Env, Ee) :- + new_atom(X), elaborate(pi(X, T1, T2), Env, Ee). +elaborate(app(E1, E2, E3, E4), Env, Ee) :- + elaborate(app(app(E1,E2,E3),E4), Env, Ee). +elaborate(app(E1, E2, E3), Env, Ee) :- elaborate(app(app(E1,E2),E3), Env, Ee). +elaborate(lambda(X, B), Env, Ee) :- elaborate(lambda(X, _, B), Env, Ee). +elaborate(let(X, E1, E2), Env, Ee) :- elaborate(let(X, _, E1, E2), Env, Ee). +elaborate(fix(F,B,E), Env, Ee) :- elaborate(fix(F,_,B,E), Env, Ee). +elaborate(fix(F,T,B,E), Env, Ee) :- + elaborate(let(F,T,app(fix,lambda(F,T,B)),E), Env, Ee). + +%% elab_bindings(+TS, +Env, -TS). +%% Applique `elaborate' sur l'environnment de type TS. +elab_tenv([], _, []). +elab_tenv([(X,T)|TS], Env, [(X, Tg)|TSe]) :- + elaborate(T, Env, Te), + infer(Te, Env, type), + generalize(_, Te, Env, _, Tg), + elab_tenv(TS, [(X, Tg)|Env], TSe). + + +%% elaborate(+E1, -E2) +%% Comme le `elaborate' ci-dessus, mais avec un environnement par défaut. +elaborate(SRC, E) :- + elab_tenv([(int, type), + (fix, ((t -> t) -> t)), + %% list: type → int → type + (list, (type -> int -> type)), + %% plus: int → int → int + (plus, (int -> int -> int)), + %% minus: int → int → int + (minus, (int -> int -> int)), + %% nil: list t 0 + (nil, app(app(list,t),0)), + %% cons: t -> list t n → list t (n + 1) + (cons, (t -> app(app(list,t),n) -> + app(app(list,t), app(app(plus,n),1)))) %fixindent + ], + [(type,type)], + Env), + elaborate(SRC, Env, E).