Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 4677:8f1ee2d15784

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Support full Common Lisp multiple values in C. lisp/ChangeLog 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * bytecomp.el : Update this file to support full C-level multiple values. This involves: -- Four new bytecodes, and special compiler functions to compile multiple-value-call, multiple-value-list-internal, values, values-list, and, since it now needs to pass back multiple values and is a special form, throw. -- There's a new compiler variable, byte-compile-checks-on-load, which is a list of forms that are evaluated at the very start of a file, with an error thrown if any of them give nil. -- The header is now inserted *after* compilation, giving a chance for the compilation process to influence what those checks are. There is still a check done before compilation for non-ASCII characters, to try to turn off dynamic docstrings if appopriate, in `byte-compile-maybe-reset-coding'. Space is reserved for checks; comments describing the version of the byte compiler generating the file are inserted if space remains for them. * bytecomp.el (byte-compile-version): Update this, we're a newer version of the byte compiler. * byte-optimize.el (byte-optimize-funcall): Correct a comment. * bytecomp.el (byte-compile-lapcode): Discard the arg with byte-multiple-value-call. * bytecomp.el (byte-compile-checks-and-comments-space): New variable, describe how many octets to reserve for checks at the start of byte-compiled files. * cl-compat.el: Remove the fake multiple-value implementation. Have the functions that use it use the real multiple-value implementation instead. * cl-macs.el (cl-block-wrapper, cl-block-throw): Revise the byte-compile properties of these symbols to work now we've made throw into a special form; keep the byte-compile properties as anonymous lambdas, since we don't have docstrings for them. * cl-macs.el (multiple-value-bind, multiple-value-setq) (multiple-value-list, nth-value): Update these functions to work with the C support for multiple values. * cl-macs.el (values): Modify the setf handler for this to call #'multiple-value-list-internal appropriately. * cl-macs.el (cl-setf-do-store): If the store form is a cons, treat it specially as wrapping the store value. * cl.el (cl-block-wrapper): Make this an alias of #'and, not #'identity, since it needs to pass back multiple values. * cl.el (multiple-value-apply): We no longer support this, mark it obsolete. * lisp-mode.el (eval-interactive-verbose): Remove a useless space in the docstring. * lisp-mode.el (eval-interactive): Update this function and its docstring. It now passes back a list, basically wrapping any eval calls with multiple-value-list. This allows multiple values to be printed by default in *scratch*. * lisp-mode.el (prin1-list-as-multiple-values): New function, printing a list as multiple values in the manner of Bruno Haible's clisp, separating each entry with " ;\n". * lisp-mode.el (eval-last-sexp): Call #'prin1-list-as-multiple-values on the return value of #'eval-interactive. * lisp-mode.el (eval-defun): Call #'prin1-list-as-multiple-values on the return value of #'eval-interactive. * mouse.el (mouse-eval-sexp): Deal with lists corresponding to multiple values from #'eval-interactive. Call #'cl-prettyprint, which is always available, instead of sometimes calling #'pprint and sometimes falling back to prin1. * obsolete.el (obsolete-throw): New function, called from eval.c when #'funcall encounters an attempt to call #'throw (now a special form) as a function. Only needed for compatibility with 21.4 byte-code. man/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * cl.texi (Organization): Remove references to the obsolete multiple-value emulating code. src/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * bytecode.c (enum Opcode /* Byte codes */): Add four new bytecodes, to deal with multiple values. (POP_WITH_MULTIPLE_VALUES): New macro. (POP): Modify this macro to ignore multiple values. (DISCARD_PRESERVING_MULTIPLE_VALUES): New macro. (DISCARD): Modify this macro to ignore multiple values. (TOP_WITH_MULTIPLE_VALUES): New macro. (TOP_ADDRESS): New macro. (TOP): Modify this macro to ignore multiple values. (TOP_LVALUE): New macro. (Bcall): Ignore multiple values where appropriate. (Breturn): Pass back multiple values. (Bdup): Preserve multiple values. Use TOP_LVALUE with most bytecodes that assign anything to anything. (Bbind_multiple_value_limits, Bmultiple_value_call, Bmultiple_value_list_internal, Bthrow): Implement the new bytecodes. (Bgotoifnilelsepop, Bgotoifnonnilelsepop, BRgotoifnilelsepop, BRgotoifnonnilelsepop): Discard any multiple values. * callint.c (Fcall_interactively): Ignore multiple values when calling #'eval, in two places. * device-x.c (x_IO_error_handler): * macros.c (pop_kbd_macro_event): * eval.c (Fsignal): * eval.c (flagged_a_squirmer): Call throw_or_bomb_out, not Fthrow, now that the latter is a special form. * eval.c: Make Qthrow, Qobsolete_throw available as symbols. Provide multiple_value_current_limit, multiple-values-limit (the latter as specified by Common Lisp. * eval.c (For): Ignore multiple values when comparing with Qnil, but pass any multiple values back for the last arg. * eval.c (Fand): Ditto. * eval.c (Fif): Ignore multiple values when examining the result of the condition. * eval.c (Fcond): Ignore multiple values when comparing what the clauses give, but pass them back if a clause gave non-nil. * eval.c (Fprog2): Never pass back multiple values. * eval.c (FletX, Flet): Ignore multiple when evaluating what exactly symbols should be bound to. * eval.c (Fwhile): Ignore multiple values when evaluating the test. * eval.c (Fsetq, Fdefvar, Fdefconst): Ignore multiple values. * eval.c (Fthrow): Declare this as a special form; ignore multiple values for TAG, preserve them for VALUE. * eval.c (throw_or_bomb_out): Make this available to other files, now Fthrow is a special form. * eval.c (Feval): Ignore multiple values when calling a compiled function, a non-special-form subr, or a lambda expression. * eval.c (Ffuncall): If we attempt to call #'throw (now a special form) as a function, don't error, call #'obsolete-throw instead. * eval.c (make_multiple_value, multiple_value_aset) (multiple_value_aref, print_multiple_value, mark_multiple_value) (size_multiple_value): Implement the multiple_value type. Add a long comment describing our implementation. * eval.c (bind_multiple_value_limits): New function, used by the bytecode and by #'multiple-value-call, #'multiple-value-list-internal. * eval.c (multiple_value_call): New function, used by the bytecode and #'multiple-value-call. * eval.c (Fmultiple_value_call): New special form. * eval.c (multiple_value_list_internal): New function, used by the byte code and #'multiple-value-list-internal. * eval.c (Fmultiple_value_list_internal, Fmultiple_value_prog1): New special forms. * eval.c (Fvalues, Fvalues_list): New Lisp functions. * eval.c (values2): New function, for C code returning multiple values. * eval.c (syms_of_eval): Make our new Lisp functions and symbols available. * eval.c (multiple-values-limit): Make this available to Lisp. * event-msw.c (dde_eval_string): * event-stream.c (execute_help_form): * glade.c (connector): * glyphs-widget.c (glyph_instantiator_to_glyph): * glyphs.c (evaluate_xpm_color_symbols): * gui-x.c (wv_set_evalable_slot, button_item_to_widget_value): * gui.c (gui_item_value, gui_item_display_flush_left): * lread.c (check_if_suppressed): * menubar-gtk.c (menu_convert, menu_descriptor_to_widget_1): * menubar-msw.c (populate_menu_add_item): * print.c (Fwith_output_to_temp_buffer): * symbols.c (Fsetq_default): Ignore multiple values when calling Feval. * symeval.h: Add the header declarations necessary for the multiple-values implementation. * inline.c: #include symeval.h, now that it has some inline functions. * lisp.h: Update Fthrow's declaration. Make throw_or_bomb_out available to all files. * lrecord.h (enum lrecord_type): Add the multiple_value type here.
author Aidan Kehoe <kehoea@parhasard.net>
date Sun, 16 Aug 2009 20:55:49 +0100
parents 517f6887fbc0
children 2ac296807b88
comparison
equal deleted inserted replaced
4676:e3feb329bda9 4677:8f1ee2d15784
713 (list* 'catch (list 'quote (intern (format "--cl-block-%s--" name))) 713 (list* 'catch (list 'quote (intern (format "--cl-block-%s--" name)))
714 body)))) 714 body))))
715 715
716 (defvar cl-active-block-names nil) 716 (defvar cl-active-block-names nil)
717 717
718 (put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block) 718 (put 'cl-block-wrapper 'byte-compile
719 (defun cl-byte-compile-block (cl-form) 719 #'(lambda (cl-form)
720 (if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing compiler 720 (if (/= (length cl-form) 2)
721 (progn 721 (byte-compile-warn-wrong-args cl-form 1))
722 (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil)) 722
723 (cl-active-block-names (cons cl-entry cl-active-block-names)) 723 (if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing
724 (cl-body (byte-compile-top-level 724 ; compiler
725 (cons 'progn (cddr (nth 1 cl-form)))))) 725 (progn
726 (if (cdr cl-entry) 726 (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil))
727 (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form)) cl-body)) 727 (cl-active-block-names (cons cl-entry
728 (byte-compile-form cl-body)))) 728 cl-active-block-names))
729 (byte-compile-form (nth 1 cl-form)))) 729 (cl-body (byte-compile-top-level
730 730 (cons 'progn (cddr (nth 1 cl-form))))))
731 (put 'cl-block-throw 'byte-compile 'cl-byte-compile-throw) 731 (if (cdr cl-entry)
732 (defun cl-byte-compile-throw (cl-form) 732 (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form))
733 (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names))) 733 cl-body))
734 (if cl-found (setcdr cl-found t))) 734 (byte-compile-form cl-body))))
735 (byte-compile-normal-call (cons 'throw (cdr cl-form)))) 735 (byte-compile-form (nth 1 cl-form)))))
736
737 (put 'cl-block-throw 'byte-compile
738 #'(lambda (cl-form)
739 (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names)))
740 (if cl-found (setcdr cl-found t)))
741 (byte-compile-throw (cons 'throw (cdr cl-form)))))
736 742
737 ;;;###autoload 743 ;;;###autoload
738 (defmacro return (&optional result) 744 (defmacro return (&optional result)
739 "(return [RESULT]): return from the block named nil. 745 "(return [RESULT]): return from the block named nil.
740 This is equivalent to `(return-from nil RESULT)'." 746 This is equivalent to `(return-from nil RESULT)'."
1839 (list 'progn 1845 (list 'progn
1840 (list 'defalias (list 'quote func) 1846 (list 'defalias (list 'quote func)
1841 (list 'function (cons 'lambda rest))) 1847 (list 'function (cons 'lambda rest)))
1842 (list 'quote func))) 1848 (list 'quote func)))
1843 1849
1844 1850 ;;; Multiple values. We support full Common Lisp conventions here.
1845 ;;; Multiple values. 1851
1846 1852 ;;;###autoload
1847 ;;;###autoload 1853 (defmacro multiple-value-bind (syms form &rest body)
1848 (defmacro multiple-value-bind (vars form &rest body) 1854 "Collect and bind multiple return values.
1849 "(multiple-value-bind (SYM SYM...) FORM BODY): collect multiple return values. 1855
1850 FORM must return a list; the BODY is then executed with the first N elements 1856 If FORM returns multiple values, each symbol in SYMS is bound to one of
1851 of this list bound (`let'-style) to each of the symbols SYM in turn. This 1857 them, in order, and BODY is executed. If FORM returns fewer multiple values
1852 is analogous to the Common Lisp `multiple-value-bind' macro, using lists to 1858 than there are SYMS, remaining SYMS are bound to nil. If FORM does
1853 simulate true multiple return values. For compatibility, (values A B C) is 1859 not return multiple values, it is treated as returning one multiple value.
1854 a synonym for (list A B C)." 1860
1855 (let ((temp (gensym)) (n -1)) 1861 Returns the value given by the last element of BODY."
1856 (list* 'let* (cons (list temp form) 1862 (if (null syms)
1857 (mapcar #'(lambda (v) 1863 `(progn ,form ,@body)
1858 (list v (list 'nth (setq n (1+ n)) temp))) 1864 (if (= 1 (length syms))
1859 vars)) 1865 ;; Code written to deal with other "implementations" of multiple
1860 body))) 1866 ;; values may have a one-element SYMS.
1861 1867 `(let ((,(car syms) ,form))
1862 ;;;###autoload 1868 ,@body)
1863 (defmacro multiple-value-setq (vars form) 1869 (let ((temp (gensym)))
1864 "(multiple-value-setq (SYM SYM...) FORM): collect multiple return values. 1870 `(let* ((,temp (multiple-value-list-internal 0 ,(length syms) ,form))
1865 FORM must return a list; the first N elements of this list are stored in 1871 ,@(loop
1866 each of the symbols SYM in turn. This is analogous to the Common Lisp 1872 for var in syms
1867 `multiple-value-setq' macro, using lists to simulate true multiple return 1873 collect `(,var (prog1 (car ,temp)
1868 values. For compatibility, (values A B C) is a synonym for (list A B C)." 1874 (setq ,temp (cdr ,temp))))))
1869 (cond ((null vars) (list 'progn form nil)) 1875 ,@body)))))
1870 ((null (cdr vars)) (list 'setq (car vars) (list 'car form))) 1876
1871 (t 1877 ;;;###autoload
1872 (let* ((temp (gensym)) (n 0)) 1878 (defmacro multiple-value-setq (syms form)
1873 (list 'let (list (list temp form)) 1879 "Collect and set multiple values.
1874 (list 'prog1 (list 'setq (pop vars) (list 'car temp)) 1880
1875 (cons 'setq 1881 FORM should normally return multiple values; the first N values are stored
1876 (apply 'nconc 1882 in the symbols in SYMS in turn. If FORM returns fewer than N values, the
1877 (mapcar 1883 remaining symbols have their values set to nil. FORM not returning multiple
1878 #'(lambda (v) 1884 values is treated as FORM returning one multiple value, with other elements
1879 (list v (list 1885 of SYMS initialized to nil.
1880 'nth 1886
1881 (setq n (1+ n)) 1887 Returns the first of the multiple values given by FORM."
1882 temp))) 1888 (if (null syms)
1883 vars))))))))) 1889 ;; Never return multiple values from multiple-value-setq:
1884 1890 (and form `(values ,form))
1891 (if (= 1 (length syms))
1892 `(setq ,(car syms) ,form)
1893 (let ((temp (gensym)))
1894 `(let* ((,temp (multiple-value-list-internal 0 ,(length syms) ,form)))
1895 (setq ,@(loop
1896 for sym in syms
1897 nconc `(,sym (car-safe ,temp)
1898 ,temp (cdr-safe ,temp))))
1899 ,(car syms))))))
1900
1901 ;;;###autoload
1902 (defmacro multiple-value-list (form)
1903 "Evaluate FORM and return a list of the multiple values it returned."
1904 `(multiple-value-list-internal 0 multiple-values-limit ,form))
1905
1906 ;;;###autoload
1907 (defmacro nth-value (n form)
1908 "Evaluate FORM and return the Nth multiple value it returned."
1909 (if (integerp n)
1910 `(car (multiple-value-list-internal ,n ,(1+ n) ,form))
1911 (let ((temp (gensym)))
1912 `(let ((,temp ,n))
1913 (car (multiple-value-list-internal ,temp (1+ ,temp) ,form))))))
1885 1914
1886 ;;; Declarations. 1915 ;;; Declarations.
1887 1916
1888 ;;;###autoload 1917 ;;;###autoload
1889 (defmacro locally (&rest body) (cons 'progn body)) 1918 (defmacro locally (&rest body) (cons 'progn body))
2344 (get-setf-method x cl-macro-environment)) 2373 (get-setf-method x cl-macro-environment))
2345 args)) 2374 args))
2346 (store-temp (gensym "--values-store--"))) 2375 (store-temp (gensym "--values-store--")))
2347 (list (apply 'append (mapcar 'first methods)) 2376 (list (apply 'append (mapcar 'first methods))
2348 (apply 'append (mapcar 'second methods)) 2377 (apply 'append (mapcar 'second methods))
2349 (list store-temp) 2378 `((,store-temp
2350 (cons 'list 2379 (multiple-value-list-internal 0 ,(if args (length args) 1))))
2380 (cons 'values
2351 (mapcar #'(lambda (m) 2381 (mapcar #'(lambda (m)
2352 (cl-setf-do-store (cons (car (third m)) (fourth m)) 2382 (cl-setf-do-store (cons (car (third m)) (fourth m))
2353 (list 'pop store-temp))) 2383 (list 'pop store-temp)))
2354 methods)) 2384 methods))
2355 (cons 'list (mapcar 'fifth methods))))) 2385 (cons 'list (mapcar 'fifth methods)))))
2408 (sublis subs (nth 4 method))))) 2438 (sublis subs (nth 4 method)))))
2409 2439
2410 (defun cl-setf-do-store (spec val) 2440 (defun cl-setf-do-store (spec val)
2411 (let ((sym (car spec)) 2441 (let ((sym (car spec))
2412 (form (cdr spec))) 2442 (form (cdr spec)))
2413 (if (or (cl-const-expr-p val) 2443 (if (consp sym)
2414 (and (cl-simple-expr-p val) (eq (cl-expr-contains form sym) 1)) 2444 ;; XEmacs change, only used for implementing #'values at the moment.
2415 (cl-setf-simple-store-p sym form)) 2445 (let* ((orig (copy-list sym))
2416 (subst val sym form) 2446 (intermediate (last orig))
2417 (list 'let (list (list sym val)) form)))) 2447 (circular-limit 32))
2448 (while (consp (car intermediate))
2449 (when (zerop circular-limit)
2450 (error 'circular-list "Form seems to contain loops"))
2451 (setq intermediate (last (car intermediate))
2452 circular-limit (1- circular-limit)))
2453 (setcdr intermediate (list val))
2454 `(let (,orig)
2455 ,form))
2456 (if (or (cl-const-expr-p val)
2457 (and (cl-simple-expr-p val)
2458 (eq (cl-expr-contains form sym) 1))
2459 (cl-setf-simple-store-p sym form))
2460 (subst val sym form)
2461 (list 'let (list (list sym val)) form)))))
2418 2462
2419 (defun cl-setf-simple-store-p (sym form) 2463 (defun cl-setf-simple-store-p (sym form)
2420 (and (consp form) (eq (cl-expr-contains form sym) 1) 2464 (and (consp form) (eq (cl-expr-contains form sym) 1)
2421 (eq (nth (1- (length form)) form) sym) 2465 (eq (nth (1- (length form)) form) sym)
2422 (symbolp (car form)) (fboundp (car form)) 2466 (symbolp (car form)) (fboundp (car form))