Changeset 8399
- Timestamp:
- 01/24/05 19:17:41 (18 years ago)
- Location:
- trunk/j/src/org/armedbear/lisp
- Files:
-
- 3 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/j/src/org/armedbear/lisp/Keyword.java
r8392 r8399 2 2 * Keyword.java 3 3 * 4 * Copyright (C) 2002-200 4Peter Graves5 * $Id: Keyword.java,v 1.3 7 2005-01-24 14:02:57 asimonExp $4 * Copyright (C) 2002-2005 Peter Graves 5 * $Id: Keyword.java,v 1.38 2005-01-24 19:10:49 piso Exp $ 6 6 * 7 7 * This program is free software; you can redistribute it and/or -
trunk/j/src/org/armedbear/lisp/clos.lisp
r8391 r8399 1 1 ;;; clos.lisp 2 2 ;;; 3 ;;; Copyright (C) 2003-200 4Peter Graves4 ;;; $Id: clos.lisp,v 1.13 3 2005-01-24 14:00:06 asimonExp $3 ;;; Copyright (C) 2003-2005 Peter Graves 4 ;;; $Id: clos.lisp,v 1.134 2005-01-24 19:15:06 piso Exp $ 5 5 ;;; 6 6 ;;; This program is free software; you can redistribute it and/or … … 546 546 (let ((name1 (canonical-slot-name s1))) 547 547 (dolist (s2 (cdr (memq s1 slots))) 548 548 (when (eq name1 (canonical-slot-name s2)) 549 549 (error 'program-error "Duplicate slot ~S" name1)))))) 550 550 ;; Check for duplicate argument names in :DEFAULT-INITARGS. … … 642 642 (or (gethash object *eql-specializer-table*) 643 643 (setf (gethash object *eql-specializer-table*) 644 644 (make-eql-specializer :object object)))) 645 645 646 646 (defclass standard-generic-function (generic-function) … … 1108 1108 but ~?~:>" 1109 1109 :format-arguments (list method gf string args))) 1110 1110 (comparison-description (x y) 1111 1111 (if (> x y) "more" "fewer"))) 1112 1112 (let ((gf-nreq (arg-info-number-required arg-info)) 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1113 (gf-nopt (arg-info-number-optional arg-info)) 1114 (gf-key/rest-p (arg-info-key/rest-p arg-info)) 1115 (gf-keywords (arg-info-keys arg-info))) 1116 (unless (= nreq gf-nreq) 1117 (lose 1118 "the method has ~A required arguments than the generic function." 1119 (comparison-description nreq gf-nreq))) 1120 (unless (= nopt gf-nopt) 1121 (lose 1122 "the method has ~A optional arguments than the generic function." 1123 (comparison-description nopt gf-nopt))) 1124 (unless (eq (or keysp restp) gf-key/rest-p) 1125 (lose 1126 "the method and generic function differ in whether they accept~_~ 1127 &REST or &KEY arguments.")) 1128 (when (consp gf-keywords) 1129 (unless (or (and restp (not keysp)) 1130 allow-other-keys-p 1131 (every (lambda (k) (memq k keywords)) gf-keywords)) 1132 (lose "the method does not accept each of the &KEY arguments~2I~_~ 1133 1133 ~S." 1134 1134 gf-keywords))))))) 1135 1135 1136 1136 (defun check-method-lambda-list (method-lambda-list gf-lambda-list) … … 1458 1458 (funcall (method-function after) args nil))))) 1459 1459 nil))) 1460 1460 (setf code (or (compile nil code) code)) 1461 1461 code)) 1462 1462 (t … … 1852 1852 1853 1853 (defmacro define-condition (name (&rest parent-types) (&rest slot-specs) 1854 1854 &body options) 1855 1855 (let ((parent-types (or parent-types '(condition))) 1856 1856 (report nil)) … … 1872 1872 (call-next-method) 1873 1873 (funcall ,report condition stream))) 1874 1874 (setf (get ',name 'sys::condition-report-function) ,report) 1875 1875 ',name) 1876 1876 `(progn … … 1886 1886 (defun coerce-to-condition (datum arguments default-type fun-name) 1887 1887 (cond ((typep datum 'condition) 1888 1888 (when arguments 1889 1889 (error 'simple-type-error 1890 1890 :datum arguments … … 1892 1892 :format-control "You may not supply additional arguments when giving ~S to ~S." 1893 1893 :format-arguments (list datum fun-name))) 1894 1895 1896 1897 1898 1894 datum) 1895 ((symbolp datum) 1896 (apply #'make-condition datum arguments)) 1897 ((or (stringp datum) (functionp datum)) 1898 (make-condition default-type 1899 1899 :format-control datum 1900 1900 :format-arguments arguments)) 1901 1902 1903 1904 1905 1906 1901 (t 1902 (error 'simple-type-error 1903 :datum datum 1904 :expected-type '(or symbol string) 1905 :format-control "Bad argument to ~S: ~S." 1906 :format-arguments (list fun-name datum))))) 1907 1907 1908 1908 ;; Originally defined in Primitives.java. Redefined here to support arbitrary … … 1938 1938 (defmethod no-applicable-method (generic-function &rest args) 1939 1939 (error "No applicable method for the generic function ~S when called with arguments ~S." 1940 1941 1940 generic-function 1941 args)) 1942 1942 1943 1943 (provide 'clos) -
trunk/j/src/org/armedbear/lisp/debug.lisp
r8391 r8399 1 1 ;;; debug.lisp 2 2 ;;; 3 ;;; Copyright (C) 2003-200 4Peter Graves4 ;;; $Id: debug.lisp,v 1. 29 2005-01-24 14:00:08 asimonExp $3 ;;; Copyright (C) 2003-2005 Peter Graves 4 ;;; $Id: debug.lisp,v 1.30 2005-01-24 19:17:41 piso Exp $ 5 5 ;;; 6 6 ;;; This program is free software; you can redistribute it and/or
Note: See TracChangeset
for help on using the changeset viewer.