[armedbear-cvs] r14349 - branches/1.1.x/src/org/armedbear/lisp
mevenson at common-lisp.net
mevenson at common-lisp.net
Sun Jan 6 07:50:00 UTC 2013
Author: mevenson
Date: Sat Jan 5 23:49:58 2013
New Revision: 14349
Log:
Backport r14346 | rschlatte | 2013-01-01 23:25:37 +0100 (Tue, 01 Jan 2013) | 1 line.
Added:
branches/1.1.x/src/org/armedbear/lisp/documentation.lisp
Modified:
branches/1.1.x/src/org/armedbear/lisp/autoloads-gen.lisp
branches/1.1.x/src/org/armedbear/lisp/clos.lisp
branches/1.1.x/src/org/armedbear/lisp/compile-system.lisp
Modified: branches/1.1.x/src/org/armedbear/lisp/autoloads-gen.lisp
==============================================================================
--- branches/1.1.x/src/org/armedbear/lisp/autoloads-gen.lisp Sat Jan 5 23:45:29 2013 (r14348)
+++ branches/1.1.x/src/org/armedbear/lisp/autoloads-gen.lisp Sat Jan 5 23:49:58 2013 (r14349)
@@ -163,7 +163,7 @@
;; FUNCTIONS
(IN-PACKAGE :CL)
-(DOLIST (SYSTEM::FS (QUOTE ((("adjoin") ADJOIN) (("apropos") APROPOS-LIST APROPOS) (("arrays") MAKE-ARRAY ADJUST-ARRAY ARRAY-ROW-MAJOR-INDEX BIT SBIT) (("assoc") ASSOC ASSOC-IF ASSOC-IF-NOT RASSOC RASSOC-IF RASSOC-IF-NOT ACONS PAIRLIS COPY-ALIST) (("bit-array-ops") BIT-AND BIT-IOR BIT-XOR BIT-EQV BIT-NAND BIT-NOR BIT-ANDC1 BIT-ANDC2 BIT-ORC1 BIT-ORC2 BIT-NOT) (("boole") BOOLE) (("butlast") BUTLAST NBUTLAST) (("byte-io") WRITE-BYTE READ-BYTE) (("chars") CHAR/= CHAR> CHAR>= CHAR-NOT-EQUAL) (("clos") CLASS-NAME NO-APPLICABLE-METHOD FUNCTION-KEYWORDS SLOT-VALUE SLOT-BOUNDP SLOT-MAKUNBOUND SLOT-EXISTS-P METHOD-QUALIFIERS ENSURE-GENERIC-FUNCTION COMPUTE-APPLICABLE-METHODS DOCUMENTATION SLOT-MISSING SLOT-UNBOUND ALLOCATE-INSTANCE INITIALIZE-INSTANCE REINITIALIZE-INSTANCE CHANGE-CLASS UPDATE-INSTANCE-FOR-DIFFERENT-CLASS MAKE-INSTANCES-OBSOLETE UPDATE-INSTANCE-FOR-REDEFINED-CLASS MAKE-CONDITION INVALID-METHOD-ERROR METHOD-COMBINATION-ERROR FIND-METHOD ADD-METHOD REMOVE-METHOD NO-NEXT-METHOD) (("coerce") COERCE) (("compile-file-pathname") COMPILE-FILE-PATHNAME) (("compile-file") COMPILE-FILE) (("compiler-macro") COMPILER-MACRO-FUNCTION) (("compiler-pass2") COMPILE) (("concatenate") CONCATENATE) (("copy-seq") COPY-SEQ) (("copy-symbol") COPY-SYMBOL) (("count") COUNT COUNT-IF COUNT-IF-NOT) (("debug") INVOKE-DEBUGGER BREAK) (("delete-duplicates") DELETE-DUPLICATES) (("delete") DELETE DELETE-IF DELETE-IF-NOT) (("deposit-field") DEPOSIT-FIELD) (("describe") DESCRIBE) (("directory") DIRECTORY) (("disassemble") DISASSEMBLE) (("dribble") DRIBBLE) (("ed") ED) (("enough-namestring") ENOUGH-NAMESTRING) (("ensure-directories-exist") ENSURE-DIRECTORIES-EXIST) (("fill") FILL) (("find-all-symbols") FIND-ALL-SYMBOLS) (("find") POSITION POSITION-IF POSITION-IF-NOT FIND FIND-IF FIND-IF-NOT) (("format") FORMAT) (("gentemp") GENTEMP) (("inspect") INSPECT) (("lcm") LCM) (("ldb") BYTE BYTE-SIZE BYTE-POSITION LDB LDB-TEST DPB) (("ldiff") LDIFF) (("list-length") LIST-LENGTH) (("list") FIFTH SIXTH SEVENTH EIGHTH NINTH TENTH MAKE-LIST COMPLEMENT CONSTANTLY MEMBER) (("load") LOAD) (("make-hash-table") MAKE-HASH-TABLE) (("make-load-form-saving-slots") MAKE-LOAD-FORM-SAVING-SLOTS) (("make-sequence") MAKE-SEQUENCE) (("make-string-output-stream") MAKE-STRING-OUTPUT-STREAM) (("make-string") MAKE-STRING) (("map-into") MAP-INTO) (("map") MAP) (("map1") MAPCAN MAPL MAPLIST MAPCON) (("mask-field") MASK-FIELD) (("member-if") MEMBER-IF MEMBER-IF-NOT) (("mismatch") BAD-SEQ-LIMIT THE-END THE-START CALL-TEST TEST-ERROR MISMATCH) (("nsubstitute") NSUBSTITUTE NSUBSTITUTE-IF NSUBSTITUTE-IF-NOT) (("numbers") SIGNUM ROUND FFLOOR FCEILING FROUND RATIONALIZE GCD ISQRT FLOAT-PRECISION DECODE-FLOAT CONJUGATE PHASE) (("open") OPEN) (("package") MAKE-PACKAGE IMPORT DELETE-PACKAGE) (("parse-integer") PARSE-INTEGER) (("pathnames") PATHNAME-HOST PATHNAME-DEVICE PATHNAME-DIRECTORY PATHNAME-NAME PATHNAME-TYPE WILD-PATHNAME-P PATHNAME-MATCH-P TRANSLATE-PATHNAME LOGICAL-PATHNAME-TRANSLATIONS TRANSLATE-LOGICAL-PATHNAME LOAD-LOGICAL-PATHNAME-TRANSLATIONS LOGICAL-PATHNAME PARSE-NAMESTRING) (("pprint-dispatch") COPY-PPRINT-DISPATCH SET-PPRINT-DISPATCH PPRINT-DISPATCH) (("pprint") WRITE PRINT PRIN1 PRINC PPRINT WRITE-TO-STRING PRIN1-TO-STRING PRINC-TO-STRING WRITE-CHAR WRITE-STRING WRITE-LINE TERPRI FRESH-LINE FINISH-OUTPUT FORCE-OUTPUT CLEAR-OUTPUT PPRINT-NEWLINE PPRINT-INDENT PPRINT-TAB PPRINT-LINEAR PPRINT-FILL PPRINT-TABULAR) (("proclaim") PROCLAIM) (("query") Y-OR-N-P YES-OR-NO-P) (("read-from-string") READ-FROM-STRING) (("read-sequence") READ-SEQUENCE) (("reduce") REDUCE) (("remove-duplicates") REMOVE-DUPLICATES) (("remove") REMOVE REMOVE-IF REMOVE-IF-NOT) (("replace") REPLACE) (("revappend") REVAPPEND) (("search") SEARCH) (("setf") GET-SETF-EXPANSION) (("sets") UNION NUNION INTERSECTION NINTERSECTION SET-DIFFERENCE NSET-DIFFERENCE SET-EXCLUSIVE-OR NSET-EXCLUSIVE-OR SUBSETP) (("sort") MERGE SORT STABLE-SORT) (("strings") STRING-UPCASE STRING-DOWNCASE STRING-CAPITALIZE NSTRING-UPCASE NSTRING-DOWNCASE NSTRING-CAPITALIZE STRING= STRING/= STRING-EQUAL STRING-NOT-EQUAL STRING< STRING> STRING<= STRING>= STRING-LESSP STRING-GREATERP STRING-NOT-LESSP STRING-NOT-GREATERP STRING-LEFT-TRIM STRING-RIGHT-TRIM STRING-TRIM) (("sublis") SUBLIS NSUBLIS) (("subst") SUBST SUBST-IF SUBST-IF-NOT NSUBST NSUBST-IF NSUBST-IF-NOT) (("substitute") LIST-SUBSTITUTE* VECTOR-SUBSTITUTE* SUBSTITUTE SUBSTITUTE-IF SUBSTITUTE-IF-NOT) (("subtypep") SUBTYPEP) (("tailp") TAILP) (("time") DECODE-UNIVERSAL-TIME GET-DECODED-TIME ENCODE-UNIVERSAL-TIME) (("tree-equal") TREE-EQUAL) (("typep") TYPEP) (("upgraded-complex-part-type") UPGRADED-COMPLEX-PART-TYPE) (("write-sequence") WRITE-SEQUENCE)))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS))))
+(DOLIST (SYSTEM::FS (QUOTE ((("adjoin") ADJOIN) (("apropos") APROPOS-LIST APROPOS) (("arrays") MAKE-ARRAY ADJUST-ARRAY ARRAY-ROW-MAJOR-INDEX BIT SBIT) (("assoc") ASSOC ASSOC-IF ASSOC-IF-NOT RASSOC RASSOC-IF RASSOC-IF-NOT ACONS PAIRLIS COPY-ALIST) (("bit-array-ops") BIT-AND BIT-IOR BIT-XOR BIT-EQV BIT-NAND BIT-NOR BIT-ANDC1 BIT-ANDC2 BIT-ORC1 BIT-ORC2 BIT-NOT) (("boole") BOOLE) (("butlast") BUTLAST NBUTLAST) (("byte-io") WRITE-BYTE READ-BYTE) (("chars") CHAR/= CHAR> CHAR>= CHAR-NOT-EQUAL) (("clos") CLASS-NAME NO-APPLICABLE-METHOD FUNCTION-KEYWORDS SLOT-VALUE SLOT-BOUNDP SLOT-MAKUNBOUND SLOT-EXISTS-P METHOD-QUALIFIERS ENSURE-GENERIC-FUNCTION COMPUTE-APPLICABLE-METHODS SLOT-MISSING SLOT-UNBOUND ALLOCATE-INSTANCE INITIALIZE-INSTANCE REINITIALIZE-INSTANCE CHANGE-CLASS UPDATE-INSTANCE-FOR-DIFFERENT-CLASS MAKE-INSTANCES-OBSOLETE UPDATE-INSTANCE-FOR-REDEFINED-CLASS MAKE-CONDITION INVALID-METHOD-ERROR METHOD-COMBINATION-ERROR FIND-METHOD ADD-METHOD REMOVE-METHOD NO-NEXT-METHOD) (("coerce") COERCE) (("compile-file-pathname") COMPILE-FILE-PATHNAME) (("compile-file") COMPILE-FILE) (("compiler-macro") COMPILER-MACRO-FUNCTION) (("compiler-pass2") COMPILE) (("concatenate") CONCATENATE) (("copy-seq") COPY-SEQ) (("copy-symbol") COPY-SYMBOL) (("count") COUNT COUNT-IF COUNT-IF-NOT) (("debug") INVOKE-DEBUGGER BREAK) (("delete-duplicates") DELETE-DUPLICATES) (("delete") DELETE DELETE-IF DELETE-IF-NOT) (("deposit-field") DEPOSIT-FIELD) (("describe") DESCRIBE) (("directory") DIRECTORY) (("disassemble") DISASSEMBLE) (("documentation") DOCUMENTATION) (("dribble") DRIBBLE) (("ed") ED) (("enough-namestring") ENOUGH-NAMESTRING) (("ensure-directories-exist") ENSURE-DIRECTORIES-EXIST) (("fill") FILL) (("find-all-symbols") FIND-ALL-SYMBOLS) (("find") POSITION POSITION-IF POSITION-IF-NOT FIND FIND-IF FIND-IF-NOT) (("format") FORMAT) (("gentemp") GENTEMP) (("inspect") INSPECT) (("lcm") LCM) (("ldb") BYTE BYTE-SIZE BYTE-POSITION LDB LDB-TEST DPB) (("ldiff") LDIFF) (("list-length") LIST-LENGTH) (("list") FIFTH SIXTH SEVENTH EIGHTH NINTH TENTH MAKE-LIST COMPLEMENT CONSTANTLY MEMBER) (("load") LOAD) (("make-hash-table") MAKE-HASH-TABLE) (("make-load-form-saving-slots") MAKE-LOAD-FORM-SAVING-SLOTS) (("make-sequence") MAKE-SEQUENCE) (("make-string-output-stream") MAKE-STRING-OUTPUT-STREAM) (("make-string") MAKE-STRING) (("map-into") MAP-INTO) (("map") MAP) (("map1") MAPCAN MAPL MAPLIST MAPCON) (("mask-field") MASK-FIELD) (("member-if") MEMBER-IF MEMBER-IF-NOT) (("mismatch") BAD-SEQ-LIMIT THE-END THE-START CALL-TEST TEST-ERROR MISMATCH) (("nsubstitute") NSUBSTITUTE NSUBSTITUTE-IF NSUBSTITUTE-IF-NOT) (("numbers") SIGNUM ROUND FFLOOR FCEILING FROUND RATIONALIZE GCD ISQRT FLOAT-PRECISION DECODE-FLOAT CONJUGATE PHASE) (("open") OPEN) (("package") MAKE-PACKAGE IMPORT DELETE-PACKAGE) (("parse-integer") PARSE-INTEGER) (("pathnames") PATHNAME-HOST PATHNAME-DEVICE PATHNAME-DIRECTORY PATHNAME-NAME PATHNAME-TYPE WILD-PATHNAME-P PATHNAME-MATCH-P TRANSLATE-PATHNAME LOGICAL-PATHNAME-TRANSLATIONS TRANSLATE-LOGICAL-PATHNAME LOAD-LOGICAL-PATHNAME-TRANSLATIONS LOGICAL-PATHNAME PARSE-NAMESTRING) (("pprint-dispatch") COPY-PPRINT-DISPATCH SET-PPRINT-DISPATCH PPRINT-DISPATCH) (("pprint") WRITE PRINT PRIN1 PRINC PPRINT WRITE-TO-STRING PRIN1-TO-STRING PRINC-TO-STRING WRITE-CHAR WRITE-STRING WRITE-LINE TERPRI FRESH-LINE FINISH-OUTPUT FORCE-OUTPUT CLEAR-OUTPUT PPRINT-NEWLINE PPRINT-INDENT PPRINT-TAB PPRINT-LINEAR PPRINT-FILL PPRINT-TABULAR) (("proclaim") PROCLAIM) (("query") Y-OR-N-P YES-OR-NO-P) (("read-from-string") READ-FROM-STRING) (("read-sequence") READ-SEQUENCE) (("reduce") REDUCE) (("remove-duplicates") REMOVE-DUPLICATES) (("remove") REMOVE REMOVE-IF REMOVE-IF-NOT) (("replace") REPLACE) (("revappend") REVAPPEND) (("search") SEARCH) (("setf") GET-SETF-EXPANSION) (("sets") UNION NUNION INTERSECTION NINTERSECTION SET-DIFFERENCE NSET-DIFFERENCE SET-EXCLUSIVE-OR NSET-EXCLUSIVE-OR SUBSETP) (("sort") MERGE SORT STABLE-SORT) (("strings") STRING-UPCASE STRING-DOWNCASE STRING-CAPITALIZE NSTRING-UPCASE NSTRING-DOWNCASE NSTRING-CAPITALIZE STRING= STRING/= STRING-EQUAL STRING-NOT-EQUAL STRING< STRING> STRING<= STRING>= STRING-LESSP STRING-GREATERP STRING-NOT-LESSP STRING-NOT-GREATERP STRING-LEFT-TRIM STRING-RIGHT-TRIM STRING-TRIM) (("sublis") SUBLIS NSUBLIS) (("subst") SUBST SUBST-IF SUBST-IF-NOT NSUBST NSUBST-IF NSUBST-IF-NOT) (("substitute") LIST-SUBSTITUTE* VECTOR-SUBSTITUTE* SUBSTITUTE SUBSTITUTE-IF SUBSTITUTE-IF-NOT) (("subtypep") SUBTYPEP) (("tailp") TAILP) (("time") DECODE-UNIVERSAL-TIME GET-DECODED-TIME ENCODE-UNIVERSAL-TIME) (("tree-equal") TREE-EQUAL) (("typep") TYPEP) (("upgraded-complex-part-type") UPGRADED-COMPLEX-PART-TYPE) (("write-sequence") WRITE-SEQUENCE)))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS))))
;; MACROS
Modified: branches/1.1.x/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- branches/1.1.x/src/org/armedbear/lisp/clos.lisp Sat Jan 5 23:45:29 2013 (r14348)
+++ branches/1.1.x/src/org/armedbear/lisp/clos.lisp Sat Jan 5 23:49:58 2013 (r14349)
@@ -1,7 +1,7 @@
;;; clos.lisp
;;;
;;; Copyright (C) 2003-2007 Peter Graves
-;;; Copyright (C) 2010 Mark Evenson
+;;; Copyright (C) 2010-2013 Mark Evenson
;;; $Id$
;;;
;;; This program is free software; you can redistribute it and/or
@@ -3254,133 +3254,6 @@
(declare (ignore initargs))
+the-standard-writer-method-class+)
-(atomic-defgeneric documentation (x doc-type)
- (:method ((x symbol) doc-type)
- (%documentation x doc-type))
- (:method ((x function) doc-type)
- (%documentation x doc-type)))
-
-(atomic-defgeneric (setf documentation) (new-value x doc-type)
- (:method (new-value (x symbol) doc-type)
- (%set-documentation x doc-type new-value))
- (:method (new-value (x function) doc-type)
- (%set-documentation x doc-type new-value)))
-
-
-;; FIXME This should be a weak hashtable!
-(defvar *list-documentation-hashtable* (make-hash-table :test #'equal))
-
-(defmethod documentation ((x list) (doc-type (eql 'function)))
- (let ((alist (gethash x *list-documentation-hashtable*)))
- (and alist (cdr (assoc doc-type alist)))))
-
-(defmethod documentation ((x list) (doc-type (eql 'compiler-macro)))
- (let ((alist (gethash x *list-documentation-hashtable*)))
- (and alist (cdr (assoc doc-type alist)))))
-
-(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function)))
- (let* ((alist (gethash x *list-documentation-hashtable*))
- (entry (and alist (assoc doc-type alist))))
- (cond (entry
- (setf (cdr entry) new-value))
- (t
- (setf (gethash x *list-documentation-hashtable*)
- (push (cons doc-type new-value) alist)))))
- new-value)
-
-(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'compiler-macro)))
- (let* ((alist (gethash x *list-documentation-hashtable*))
- (entry (and alist (assoc doc-type alist))))
- (cond (entry
- (setf (cdr entry) new-value))
- (t
- (setf (gethash x *list-documentation-hashtable*)
- (push (cons doc-type new-value) alist)))))
- new-value)
-
-(defmethod documentation ((x class) (doc-type (eql 't)))
- (class-documentation x))
-
-(defmethod documentation ((x class) (doc-type (eql 'type)))
- (class-documentation x))
-
-(defmethod (setf documentation) (new-value (x class) (doc-type (eql 't)))
- (%set-class-documentation x new-value))
-
-(defmethod (setf documentation) (new-value (x class) (doc-type (eql 'type)))
- (%set-class-documentation x new-value))
-
-(defmethod documentation ((x structure-class) (doc-type (eql 't)))
- (%documentation x t))
-
-(defmethod documentation ((x structure-class) (doc-type (eql 'type)))
- (%documentation x t))
-
-(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 't)))
- (%set-documentation x t new-value))
-
-(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 'type)))
- (%set-documentation x t new-value))
-
-(defmethod documentation ((x standard-generic-function) (doc-type (eql 't)))
- (generic-function-documentation x))
-
-(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 't)))
- (setf (generic-function-documentation x) new-value))
-
-(defmethod documentation ((x standard-generic-function) (doc-type (eql 'function)))
- (generic-function-documentation x))
-
-(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 'function)))
- (setf (generic-function-documentation x) new-value))
-
-(defmethod documentation ((x standard-method) (doc-type (eql 't)))
- (method-documentation x))
-
-(defmethod (setf documentation) (new-value (x standard-method) (doc-type (eql 't)))
- (setf (method-documentation x) new-value))
-
-(defmethod documentation ((x standard-slot-definition) (doc-type (eql 't)))
- (slot-definition-documentation x))
-
-(defmethod (setf documentation) (new-value (x standard-slot-definition) (doc-type (eql 't)))
- (setf (slot-definition-documentation x) new-value))
-
-(defmethod documentation ((x package) (doc-type (eql 't)))
- (%documentation x doc-type))
-
-(defmethod (setf documentation) (new-value (x package) (doc-type (eql 't)))
- (%set-documentation x doc-type new-value))
-
-(defmethod documentation ((x symbol) (doc-type (eql 'function)))
- (if (and (fboundp x) (typep (fdefinition x) 'generic-function))
- (documentation (fdefinition x) doc-type)
- (%documentation x doc-type)))
-
-(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'function)))
- (if (and (fboundp x) (typep (fdefinition x) 'generic-function))
- (setf (documentation (fdefinition x) 'function) new-value)
- (%set-documentation x 'function new-value)))
-
-(defmethod documentation ((x symbol) (doc-type (eql 'type)))
- (let ((class (find-class x nil)))
- (if class
- (documentation class t)
- (%documentation x 'type))))
-
-(defmethod documentation ((x symbol) (doc-type (eql 'structure)))
- (%documentation x 'structure))
-
-(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type)))
- (let ((class (find-class x nil)))
- (if class
- (setf (documentation class t) new-value)
- (%set-documentation x 'type new-value))))
-
-(defmethod (setf documentation) (new-value (x symbol)
- (doc-type (eql 'structure)))
- (%set-documentation x 'structure new-value))
-
;;; Applicable methods
(atomic-defgeneric compute-applicable-methods (gf args)
Modified: branches/1.1.x/src/org/armedbear/lisp/compile-system.lisp
==============================================================================
--- branches/1.1.x/src/org/armedbear/lisp/compile-system.lisp Sat Jan 5 23:45:29 2013 (r14348)
+++ branches/1.1.x/src/org/armedbear/lisp/compile-system.lisp Sat Jan 5 23:49:58 2013 (r14349)
@@ -343,6 +343,7 @@
"do-external-symbols.lisp"
"do-symbols.lisp"
"do.lisp"
+ "documentation.lisp"
"dolist.lisp"
"dotimes.lisp"
"dribble.lisp"
Added: branches/1.1.x/src/org/armedbear/lisp/documentation.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/1.1.x/src/org/armedbear/lisp/documentation.lisp Sat Jan 5 23:49:58 2013 (r14349)
@@ -0,0 +1,169 @@
+;;; documentation.lisp
+;;;
+;;; Copyright (C) 2003-2007 Peter Graves
+;;; Copyright (C) 2010-2013 Mark Evenson
+;;;
+;;; This program 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 2
+;;; of the License, or (at your option) any later version.
+;;;
+;;; This program 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 this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+;;;
+;;; As a special exception, the copyright holders of this library give you
+;;; permission to link this library with independent modules to produce an
+;;; executable, regardless of the license terms of these independent
+;;; modules, and to copy and distribute the resulting executable under
+;;; terms of your choice, provided that you also meet, for each linked
+;;; independent module, the terms and conditions of the license of that
+;;; module. An independent module is a module which is not derived from
+;;; or based on this library. If you modify this library, you may extend
+;;; this exception to your version of the library, but you are not
+;;; obligated to do so. If you do not wish to do so, delete this
+;;; exception statement from your version.
+
+
+(in-package #:mop)
+
+(require "CLOS")
+
+(defgeneric documentation (x doc-type)
+ (:method ((x symbol) doc-type)
+ (%documentation x doc-type))
+ (:method ((x function) doc-type)
+ (%documentation x doc-type)))
+
+(defgeneric (setf documentation) (new-value x doc-type)
+ (:method (new-value (x symbol) doc-type)
+ (%set-documentation x doc-type new-value))
+ (:method (new-value (x function) doc-type)
+ (%set-documentation x doc-type new-value)))
+
+
+;; FIXME This should be a weak hashtable!
+(defvar *list-documentation-hashtable* (make-hash-table :test #'equal))
+
+(defmethod documentation ((x list) (doc-type (eql 'function)))
+ (let ((alist (gethash x *list-documentation-hashtable*)))
+ (and alist (cdr (assoc doc-type alist)))))
+
+(defmethod documentation ((x list) (doc-type (eql 'compiler-macro)))
+ (let ((alist (gethash x *list-documentation-hashtable*)))
+ (and alist (cdr (assoc doc-type alist)))))
+
+(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function)))
+ (let* ((alist (gethash x *list-documentation-hashtable*))
+ (entry (and alist (assoc doc-type alist))))
+ (cond
+ (entry (setf (cdr entry) new-value))
+ (t (setf (gethash x *list-documentation-hashtable*)
+ (push (cons doc-type new-value) alist)))))
+ new-value)
+
+(defmethod (setf documentation) (new-value (x list)
+ (doc-type (eql 'compiler-macro)))
+ (let* ((alist (gethash x *list-documentation-hashtable*))
+ (entry (and alist (assoc doc-type alist))))
+ (cond
+ (entry (setf (cdr entry) new-value))
+ (t (setf (gethash x *list-documentation-hashtable*)
+ (push (cons doc-type new-value) alist)))))
+ new-value)
+
+(defmethod documentation ((x class) (doc-type (eql 't)))
+ (class-documentation x))
+
+(defmethod documentation ((x class) (doc-type (eql 'type)))
+ (class-documentation x))
+
+(defmethod (setf documentation) (new-value (x class) (doc-type (eql 't)))
+ (%set-class-documentation x new-value))
+
+(defmethod (setf documentation) (new-value (x class) (doc-type (eql 'type)))
+ (%set-class-documentation x new-value))
+
+(defmethod documentation ((x structure-class) (doc-type (eql 't)))
+ (%documentation x t))
+
+(defmethod documentation ((x structure-class) (doc-type (eql 'type)))
+ (%documentation x t))
+
+(defmethod (setf documentation) (new-value (x structure-class)
+ (doc-type (eql 't)))
+ (%set-documentation x t new-value))
+
+(defmethod (setf documentation) (new-value (x structure-class)
+ (doc-type (eql 'type)))
+ (%set-documentation x t new-value))
+
+(defmethod documentation ((x standard-generic-function) (doc-type (eql 't)))
+ (generic-function-documentation x))
+
+(defmethod (setf documentation) (new-value (x standard-generic-function)
+ (doc-type (eql 't)))
+ (setf (generic-function-documentation x) new-value))
+
+(defmethod documentation ((x standard-generic-function)
+ (doc-type (eql 'function)))
+ (generic-function-documentation x))
+
+(defmethod (setf documentation) (new-value (x standard-generic-function)
+ (doc-type (eql 'function)))
+ (setf (generic-function-documentation x) new-value))
+
+(defmethod documentation ((x standard-method) (doc-type (eql 't)))
+ (method-documentation x))
+
+(defmethod (setf documentation) (new-value (x standard-method)
+ (doc-type (eql 't)))
+ (setf (method-documentation x) new-value))
+
+(defmethod documentation ((x standard-slot-definition) (doc-type (eql 't)))
+ (slot-definition-documentation x))
+
+(defmethod (setf documentation) (new-value (x standard-slot-definition)
+ (doc-type (eql 't)))
+ (setf (slot-definition-documentation x) new-value))
+
+(defmethod documentation ((x package) (doc-type (eql 't)))
+ (%documentation x doc-type))
+
+(defmethod (setf documentation) (new-value (x package) (doc-type (eql 't)))
+ (%set-documentation x doc-type new-value))
+
+(defmethod documentation ((x symbol) (doc-type (eql 'function)))
+ (if (and (fboundp x) (typep (fdefinition x) 'generic-function))
+ (documentation (fdefinition x) doc-type)
+ (%documentation x doc-type)))
+
+(defmethod (setf documentation) (new-value (x symbol)
+ (doc-type (eql 'function)))
+ (if (and (fboundp x) (typep (fdefinition x) 'generic-function))
+ (setf (documentation (fdefinition x) 'function) new-value)
+ (%set-documentation x 'function new-value)))
+
+(defmethod documentation ((x symbol) (doc-type (eql 'type)))
+ (let ((class (find-class x nil)))
+ (if class
+ (documentation class t)
+ (%documentation x 'type))))
+
+(defmethod documentation ((x symbol) (doc-type (eql 'structure)))
+ (%documentation x 'structure))
+
+(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type)))
+ (let ((class (find-class x nil)))
+ (if class
+ (setf (documentation class t) new-value)
+ (%set-documentation x 'type new-value))))
+
+(defmethod (setf documentation) (new-value (x symbol)
+ (doc-type (eql 'structure)))
+ (%set-documentation x 'structure new-value))
More information about the armedbear-cvs
mailing list