cgit.sxemacs.org Git - packages/blob - xemacs-packages/eieio/eieio-comp.el

   1 ;;; eieio-comp.el -- eieio routines to help with byte compilation
   2
   3 ;;;
   4 ;; Copyright (C) 1995,1996, 1998, 1999, 2000, 2001, 2002, 2005 Eric M. Ludlam
   5 ;;
   6 ;; Author: <zappo@gnu.org>
   7 ;; RCS: $Id: eieio-comp.el,v 1.6 2010-03-28 12:44:26 sperber-guest Exp $
   8 ;; Keywords: oop, lisp, tools
   9 ;;
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24 ;;
  25 ;; Please send bug reports, etc. to zappo@gnu.org
  26
  27 ;;; Commentary:
  28 ;;
  29 ;; Byte compiler functions for defmethod.  This will affect the new GNU
  30 ;; byte compiler for Emacs 19 and better.  This function will be called by
  31 ;; the byte compiler whenever a `defmethod' is encountered in a file.
  32 ;; It will output a function call to `eieio-defmethod' with the byte
  33 ;; compiled function as a parameter.
  34
  35 ;;; Code:
  36
  37 ;; Some compatibility stuff
  38 (eval-and-compile
  39   (if (not (fboundp 'byte-compile-compiled-obj-to-list))
  40       ;; XEmacs change; b-c-c-o-t-l has been removed in 21.5
  41       (defun byte-compile-compiled-obj-to-list (compiled-function)
  42         (nconc (list
  43                 (compiled-function-arglist compiled-function)
  44                 (compiled-function-instructions compiled-function)
  45                 (compiled-function-constants compiled-function)
  46                 (compiled-function-stack-depth compiled-function)
  47                 (compiled-function-doc-string compiled-function))
  48                (if (commandp compiled-function)
  49                    (list (nth 1 (compiled-function-interactive
  50                                  compiled-function)))))))
  51   (if (not (boundp 'byte-compile-outbuffer))
  52       (defvar byte-compile-outbuffer nil))
  53   )
  54
  55 ;; This teaches the byte compiler how to do this sort of thing.
  56 (put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod)
  57
  58 (defun byte-compile-file-form-defmethod (form)
  59   "Mumble about the method we are compiling.
  60 This function is mostly ripped from `byte-compile-file-form-defun', but
  61 it's been modified to handle the special syntax of the defmethod
  62 command.  There should probably be one for defgeneric as well, but
  63 that is called but rarely.  Argument FORM is the body of the method."
  64   (setq form (cdr form))
  65   (let* ((meth (car form))
  66          (key (progn (setq form (cdr form))
  67                      (cond ((eq ':BEFORE (car form))
  68                             (setq form (cdr form))
  69                             ":BEFORE ")
  70                            ((eq ':AFTER (car form))
  71                             (setq form (cdr form))
  72                             ":AFTER ")
  73                            ((eq ':PRIMARY (car form))
  74                             (setq form (cdr form))
  75                             ":PRIMARY ")
  76                            ((eq ':STATIC (car form))
  77                             (setq form (cdr form))
  78                             ":STATIC ")
  79                            (t ""))))
  80          (params (car form))
  81          (lamparams (byte-compile-defmethod-param-convert params))
  82          (arg1 (car params))
  83          (class (if (listp arg1) (nth 1 arg1) nil))
  84          (my-outbuffer (if (eval-when-compile
  85                              (string-match "XEmacs" emacs-version))
  86                            byte-compile-outbuffer outbuffer))
  87          )
  88     (let ((name (format "%s::%s" (or class "#<generic>") meth)))
  89       (if byte-compile-verbose
  90           ;; #### filename used free
  91           (message "Compiling %s... (%s)" (or filename "") name))
  92       (setq byte-compile-current-form name) ; for warnings
  93       )
  94     ;; Flush any pending output
  95     (byte-compile-flush-pending)
  96     ;; Byte compile the body.  For the byte compiled forms, add the
  97     ;; rest arguments, which will get ignored by the engine which will
  98     ;; add them later (I hope)
  99     (let* ((new-one (byte-compile-lambda
 100                      (append (list 'lambda lamparams)
 101                              (cdr form))))
 102            (code (byte-compile-byte-code-maker new-one)))
 103       (princ "\n(eieio-defmethod '" my-outbuffer)
 104       (princ meth my-outbuffer)
 105       (princ " '(" my-outbuffer)
 106       (princ key my-outbuffer)
 107       (prin1 params my-outbuffer)
 108       (princ " " my-outbuffer)
 109       (eieio-byte-compile-princ-code code my-outbuffer)
 110       (princ "))" my-outbuffer)
 111       )
 112     ;; Now add this function to the list of known functions.
 113     ;; Don't bother with a doc string.   Not relevant here.
 114     (add-to-list 'byte-compile-function-environment
 115                  (cons meth
 116                        (eieio-defgeneric-form meth "")))
 117
 118     ;; Remove it from the undefined list if it is there.
 119     (let ((elt (assq meth byte-compile-unresolved-functions)))
 120       (if elt (setq byte-compile-unresolved-functions
 121                     (delq elt byte-compile-unresolved-functions))))
 122
 123     ;; nil prevents cruft from appearing in the output buffer.
 124     nil))
 125
 126
 127 (defun eieio-byte-compile-princ-code (code outbuffer)
 128   "Xemacs and GNU Emacs do their things differently.
 129 Lets do it right on both platforms
 130 Argument CODE is the code to output.
 131 Argument OUTBUFFER is the buffer to dump the created code to."
 132   (if (eval-when-compile (not (featurep 'xemacs)))
 133       ;; FSF emacs
 134       (prin1 code outbuffer)
 135     ;; XEmacs
 136     (if (atom code)
 137         (princ "#[" outbuffer)
 138       (princ "'(" outbuffer))
 139     (let ((codelist (if (byte-code-function-p code)
 140                         (byte-compile-compiled-obj-to-list code)
 141                       (append code nil))))
 142       (while codelist
 143         (eieio-prin1 (car codelist) outbuffer)
 144         (princ " " outbuffer)
 145         (setq codelist (cdr codelist))
 146         ))
 147     (if (atom code)
 148         (princ "]" outbuffer)
 149       (princ ")" outbuffer))))
 150
 151 (defun eieio-prin1 (code outbuffer)
 152   "For XEmacs only, princ one item.
 153 Recurse into lists in search of `byte-code' which needs expanding...
 154 Argument CODE is the code to output.
 155 Argument OUTBUFFER is the buffer to dump the created code to."
 156   (cond ((byte-code-function-p code)
 157          (let ((codelist (byte-compile-compiled-obj-to-list code)))
 158            (princ "#[" outbuffer)
 159            (while codelist
 160              (eieio-prin1 (car codelist) outbuffer)
 161              (princ " " outbuffer)
 162              (setq codelist (cdr codelist))
 163              )
 164            (princ "]" outbuffer)))
 165         ((vectorp code)
 166          (let ((i 0) (ln (length code)))
 167            (princ "[" outbuffer)
 168            (while (< i ln)
 169              (eieio-prin1 (aref code i) outbuffer)
 170              (princ " " outbuffer)
 171              (setq i (1+ i)))
 172            (princ "]" outbuffer)))
 173         (t (prin1 code outbuffer))))
 174
 175
 176 (defun byte-compile-defmethod-param-convert (paramlist)
 177   "Convert method params into the params used by the defmethod thingy.
 178 Argument PARAMLIST is the paramter list to convert."
 179   (let ((argfix nil))
 180     (while paramlist
 181       (setq argfix (cons (if (listp (car paramlist))
 182                              (car (car paramlist))
 183                            (car paramlist))
 184                          argfix))
 185       (setq paramlist (cdr paramlist)))
 186     (nreverse argfix)))
 187
 188 (provide 'eieio-comp)
 189
 190 ;;; eieio-comp.el ends here