Changeset 7982
 Timestamp:
 Jan 1, 2008, 1:51:05 AM (12 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

branches/1.2devel/ccl/level1/l1closboot.lisp
r7945 r7982 1045 1045 1046 1046 1047 1047 (defstatic *nondtdcodefunctions* () "List of functions which return a dcode function for the GF which is their argument. The dcode functions will be caled with all of the incoming arguments.") 1048 1049 (defun nondtdcodefunction (gf) 1050 (dolist (f *nondtdcodefunctions*) 1051 (let* ((dcode (funcall f gf))) 1052 (when dcode (return dcode))))) 1053 1054 1048 1055 (defparameter dcodeprotoalist 1049 1056 (list (cons #'%%oneargdcode *gfprotoonearg*) … … 1074 1081 (if (or (null minindex) (< index minindex)) 1075 1082 (setq minindex index)))))) 1076 (let ((dcode (if 0args? 1077 #'%%0argdcode 1078 (or (if multimethodindex 1079 #'%%nthargdcode) 1080 (if (null otherargs?) 1081 (if (eql nreq 1) 1082 #'%%oneargdcode 1083 (if (eql nreq 2) 1084 #'%%1sttwoargdcode 1085 #'%%1stargdcode)) 1086 #'%%1stargdcode))))) 1083 (let* ((nondt (nondtdcodefunction gf)) 1084 (dcode (or nondt 1085 (if 0args? 1086 #'%%0argdcode 1087 (or (if multimethodindex 1088 #'%%nthargdcode) 1089 (if (null otherargs?) 1090 (if (eql nreq 1) 1091 #'%%oneargdcode 1092 (if (eql nreq 2) 1093 #'%%1sttwoargdcode 1094 #'%%1stargdcode)) 1095 #'%%1stargdcode)))))) 1087 1096 (setq multimethodindex 1088 1097 (if multimethodindex … … 1096 1105 (functionname (%combinedmethoddcode olddcode))) 1097 1106 (cdr (%combinedmethodmethods olddcode))))) 1098 (when (or (neq dcode (if encapsulateddcodecons (cdr encapsulateddcodecons) olddcode))1107 (when (or nondt (neq dcode (if encapsulateddcodecons (cdr encapsulateddcodecons) olddcode)) 1099 1108 (neq multimethodindex (%gfdispatchtableargnum dt))) 1100 (let ((proto (or (cdr (assq dcode dcodeprotoalist)) *gfproto*))) 1109 (let* ((proto (if nondt 1110 #'funcallabletrampoline 1111 (or (cdr (assq dcode dcodeprotoalist)) *gfproto*)))) 1101 1112 (cleargfdispatchtable dt) 1102 1113 (setf (%gfdispatchtableargnum dt) multimethodindex) … … 1328 1339 1329 1340 1330 (defvar *tclass* (let ((class (%consbuiltinclass 't))) 1331 (setf (%class.cpl class) (list class)) 1332 (setf (%class.ownwrapper class) 1333 (%conswrapper class (newclasswrapperhashindex))) 1341 (defvar *tclass* (let* ((class (%consbuiltinclass 't)) 1342 (wrapper (%conswrapper class (newclasswrapperhashindex))) 1343 (cpl (list class))) 1344 (setf (%class.cpl class) cpl) 1345 (setf (%wrappercpl wrapper) cpl) 1346 (setf (%class.ownwrapper class) wrapper) 1334 1347 (setf (%class.ctype class) (makeclassctype class)) 1335 1348 (setf (findclass 't) class) … … 1430 1443 (%conswrapper class)))) 1431 1444 (setf (%class.cpl class) cpl 1432 (%wrapperinstanceslots wrapper) (vector) 1445 (%wrapperinstanceslots wrapper) (vector) 1433 1446 (%class.ownwrapper class) wrapper 1434 1447 (%class.ctype class) (makeclassctype class) 1435 1448 (%class.slots class) nil 1436 ( findclass name) class1437 )1449 (%wrappercpl wrapper) cpl 1450 (findclass name) class) 1438 1451 (dolist (sup supers) 1439 1452 (setf (%class.subclasses sup) (cons class (%class.subclasses sup))))
Note: See TracChangeset
for help on using the changeset viewer.