annotate lisp/emacs-lisp/cl-compat.el @ 23889:3b5045c64434

(find-coding-systems-for-charsets): Handle the case of unknown charset. (find-multibyte-characters): If invalid multibyte characters are found, return the corresponding strings instead of character codes. (find-multibyte-characters): Adjusted for the above change. (select-safe-coding-system): For a unibyte buffer, always returns DEFAULT-CODING-SYSTEM. (get-charset-property): Fix previous change. Make it a function. (put-charset-property): Make it a function.

申鐃緒申     1 ;;; cl-compat.el --- Common Lisp extensions for GNU Emacs Lisp (compatibility)
申鐃緒申     2 
申鐃緒申     3 ;; Copyright (C) 1993 Free Software Foundation, Inc.
申鐃緒申     4 
申鐃緒申     5 ;; Author: Dave Gillespie <[e-mail]>
申鐃緒申     6 ;; Version: 2.02
申鐃緒申     7 ;; Keywords: extensions
申鐃緒申     8 
申鐃緒申     9 ;; This file is part of GNU Emacs.
申鐃緒申    10 
申鐃緒申    11 ;; GNU Emacs is free software; you can redistribute it and/or modify
申鐃緒申    12 ;; it under the terms of the GNU General Public License as published by
申鐃緒申    13 ;; the Free Software Foundation; either version 2, or (at your option)
申鐃緒申    14 ;; any later version.
申鐃緒申    15 
申鐃緒申    16 ;; GNU Emacs is distributed in the hope that it will be useful,
申鐃緒申    17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
申鐃緒申    18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
申鐃緒申    19 ;; GNU General Public License for more details.
申鐃緒申    20 
申鐃緒申    21 ;; You should have received a copy of the GNU General Public License
申鐃緒申    22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
申鐃緒申    23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
申鐃緒申    24 ;; Boston, MA 02111-1307, USA.
申鐃緒申    25 
申鐃緒申    26 ;;; Commentary:
申鐃緒申    27 
申鐃緒申    28 ;; These are extensions to Emacs Lisp that provide a degree of
申鐃緒申    29 ;; Common Lisp compatibility, beyond what is already built-in
申鐃緒申    30 ;; in Emacs Lisp.
申鐃緒申    31 ;;
申鐃緒申    32 ;; This package was written by Dave Gillespie; it is a complete
申鐃緒申    33 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
申鐃緒申    34 ;;
申鐃緒申    35 ;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19.
申鐃緒申    36 ;;
申鐃緒申    37 ;; Bug reports, comments, and suggestions are welcome!
申鐃緒申    38 
申鐃緒申    39 ;; This file contains emulations of internal routines of the older
申鐃緒申    40 ;; CL package which users may have called directly from their code.
申鐃緒申    41 ;; Use (require 'cl-compat) to get these routines.
申鐃緒申    42 
申鐃緒申    43 ;; See cl.el for Change Log.
申鐃緒申    44 
申鐃緒申    45 
申鐃緒申    46 ;;; Code:
申鐃緒申    47 
申鐃緒申    48 ;; Require at load-time, but not when compiling cl-compat.
申鐃緒申    49 (or (featurep 'cl) (require 'cl))
申鐃緒申    50 
申鐃緒申    51 
申鐃緒申    52 ;;; Keyword routines not supported by new package.
申鐃緒申    53 
申鐃緒申    54 (defmacro defkeyword (x &optional doc)
申鐃緒申    55   (list* 'defconst x (list 'quote x) (and doc (list doc))))
申鐃緒申    56 
申鐃緒申    57 (defun keywordp (sym)
申鐃緒申    58   (and (symbolp sym) (eq (aref (symbol-name sym) 0) ?\:) (set sym sym)))
申鐃緒申    59 
申鐃緒申    60 (defun keyword-of (sym)
申鐃緒申    61   (or (keywordp sym) (keywordp (intern (format ":%s" sym)))))
申鐃緒申    62 
申鐃緒申    63 
申鐃緒申    64 ;;; Multiple values.  Note that the new package uses a different
申鐃緒申    65 ;;; convention for multiple values.  The following definitions
申鐃緒申    66 ;;; emulate the old convention; all function names have been changed
申鐃緒申    67 ;;; by capitalizing the first letter: Values, Multiple-value-*,
申鐃緒申    68 ;;; to avoid conflict with the new-style definitions in cl-macs.
申鐃緒申    69 
申鐃緒申    70 (put 'Multiple-value-bind  'lisp-indent-function 2)
申鐃緒申    71 (put 'Multiple-value-setq  'lisp-indent-function 2)
申鐃緒申    72 (put 'Multiple-value-call  'lisp-indent-function 1)
申鐃緒申    73 (put 'Multiple-value-prog1 'lisp-indent-function 1)
申鐃緒申    74 
申鐃緒申    75 (defvar *mvalues-values* nil)
申鐃緒申    76 
申鐃緒申    77 (defun Values (&rest val-forms)
申鐃緒申    78   (setq *mvalues-values* val-forms)
申鐃緒申    79   (car val-forms))
申鐃緒申    80 
申鐃緒申    81 (defun Values-list (val-forms)
申鐃緒申    82   (apply 'values val-forms))
申鐃緒申    83 
申鐃緒申    84 (defmacro Multiple-value-list (form)
申鐃緒申    85   (list 'let* (list '(*mvalues-values* nil) (list '*mvalues-temp* form))
申鐃緒申    86 	'(or (and (eq *mvalues-temp* (car *mvalues-values*)) *mvalues-values*)
申鐃緒申    87 	     (list *mvalues-temp*))))
申鐃緒申    88 
申鐃緒申    89 (defmacro Multiple-value-call (function &rest args)
申鐃緒申    90   (list 'apply function
申鐃緒申    91 	(cons 'append
申鐃緒申    92 	      (mapcar (function (lambda (x) (list 'Multiple-value-list x)))
申鐃緒申    93 		      args))))
申鐃緒申    94 
申鐃緒申    95 (defmacro Multiple-value-bind (vars form &rest body)
申鐃緒申    96   (list* 'multiple-value-bind vars (list 'Multiple-value-list form) body))
申鐃緒申    97 
申鐃緒申    98 (defmacro Multiple-value-setq (vars form)
申鐃緒申    99   (list 'multiple-value-setq vars (list 'Multiple-value-list form)))
申鐃緒申   100 
申鐃緒申   101 (defmacro Multiple-value-prog1 (form &rest body)
申鐃緒申   102   (list 'prog1 form (list* 'let '((*mvalues-values* nil)) body)))
申鐃緒申   103 
申鐃緒申   104 
申鐃緒申   105 ;;; Routines for parsing keyword arguments.
申鐃緒申   106 
申鐃緒申   107 (defun build-klist (arglist keys &optional allow-others)
申鐃緒申   108   (let ((res (Multiple-value-call 'mapcar* 'cons (unzip-lists arglist))))
申鐃緒申   109     (or allow-others
申鐃緒申   110 	(let ((bad (set-difference (mapcar 'car res) keys)))
申鐃緒申   111 	  (if bad (error "Bad keywords: %s not in %s" bad keys))))
申鐃緒申   112     res))
申鐃緒申   113 
申鐃緒申   114 (defun extract-from-klist (klist key &optional def)
申鐃緒申   115   (let ((res (assq key klist))) (if res (cdr res) def)))
申鐃緒申   116 
申鐃緒申   117 (defun keyword-argument-supplied-p (klist key)
申鐃緒申   118   (assq key klist))
申鐃緒申   119 
申鐃緒申   120 (defun elt-satisfies-test-p (item elt klist)
申鐃緒申   121   (let ((test-not (cdr (assq ':test-not klist)))
申鐃緒申   122 	(test (cdr (assq ':test klist)))
申鐃緒申   123 	(key (cdr (assq ':key klist))))
申鐃緒申   124     (if key (setq elt (funcall key elt)))
申鐃緒申   125     (if test-not (not (funcall test-not item elt))
申鐃緒申   126       (funcall (or test 'eql) item elt))))
申鐃緒申   127 
申鐃緒申   128 
申鐃緒申   129 ;;; Rounding functions with old-style multiple value returns.
申鐃緒申   130 
申鐃緒申   131 (defun cl-floor (a &optional b) (Values-list (floor* a b)))
申鐃緒申   132 (defun cl-ceiling (a &optional b) (Values-list (ceiling* a b)))
申鐃緒申   133 (defun cl-round (a &optional b) (Values-list (round* a b)))
申鐃緒申   134 (defun cl-truncate (a &optional b) (Values-list (truncate* a b)))
申鐃緒申   135 
申鐃緒申   136 (defun safe-idiv (a b)
申鐃緒申   137   (let* ((q (/ (abs a) (abs b)))
申鐃緒申   138          (s (* (signum a) (signum b))))
申鐃緒申   139     (Values q (- a (* s q b)) s)))
申鐃緒申   140 
申鐃緒申   141 
申鐃緒申   142 ;; Internal routines.
申鐃緒申   143 
申鐃緒申   144 (defun pair-with-newsyms (oldforms)
申鐃緒申   145   (let ((newsyms (mapcar (function (lambda (x) (gensym))) oldforms)))
申鐃緒申   146     (Values (mapcar* 'list newsyms oldforms) newsyms)))
申鐃緒申   147 
申鐃緒申   148 (defun zip-lists (evens odds)
申鐃緒申   149   (mapcan 'list evens odds))
申鐃緒申   150 
申鐃緒申   151 (defun unzip-lists (list)
申鐃緒申   152   (let ((e nil) (o nil))
申鐃緒申   153     (while list
申鐃緒申   154       (setq e (cons (car list) e) o (cons (cadr list) o) list (cddr list)))
申鐃緒申   155     (Values (nreverse e) (nreverse o))))
申鐃緒申   156 
申鐃緒申   157 (defun reassemble-argslists (list)
申鐃緒申   158   (let ((n (apply 'min (mapcar 'length list))) (res nil))
申鐃緒申   159     (while (>= (setq n (1- n)) 0)
申鐃緒申   160       (setq res (cons (mapcar (function (lambda (x) (elt x n))) list) res)))
申鐃緒申   161     res))
申鐃緒申   162 
申鐃緒申   163 (defun duplicate-symbols-p (list)
申鐃緒申   164   (let ((res nil))
申鐃緒申   165     (while list
申鐃緒申   166       (if (memq (car list) (cdr list)) (setq res (cons (car list) res)))
申鐃緒申   167       (setq list (cdr list)))
申鐃緒申   168     res))
申鐃緒申   169 
申鐃緒申   170 
申鐃緒申   171 ;;; Setf internals.
申鐃緒申   172 
申鐃緒申   173 (defun setnth (n list x)
申鐃緒申   174   (setcar (nthcdr n list) x))
申鐃緒申   175 
申鐃緒申   176 (defun setnthcdr (n list x)
申鐃緒申   177   (setcdr (nthcdr (1- n) list) x))
申鐃緒申   178 
申鐃緒申   179 (defun setelt (seq n x)
申鐃緒申   180   (if (consp seq) (setcar (nthcdr n seq) x) (aset seq n x)))
申鐃緒申   181 
申鐃緒申   182 
申鐃緒申   183 ;;; Functions omitted: case-clausify, check-do-stepforms, check-do-endforms,
申鐃緒申   184 ;;; extract-do-inits, extract-do[*]-steps, select-stepping-forms,
申鐃緒申   185 ;;; elt-satisfies-if[-not]-p, with-keyword-args, mv-bind-clausify,
申鐃緒申   186 ;;; all names with embedded `$'.
申鐃緒申   187 
申鐃緒申   188 
申鐃緒申   189 (provide 'cl-compat)
申鐃緒申   190 
申鐃緒申   191 ;;; cl-compat.el ends here
申鐃緒申   192