[bknr-cvs] r2207 - in branches/trunk-reorg/thirdparty: . closer-mop closer-mop/_darcs closer-mop/_darcs/current closer-mop/_darcs/current/allegro closer-mop/_darcs/current/clisp closer-mop/_darcs/current/ecl closer-mop/_darcs/current/lispworks closer-mop/_darcs/current/mcl closer-mop/_darcs/current/pcl closer-mop/_darcs/current/test closer-mop/_darcs/inventories closer-mop/_darcs/patches closer-mop/_darcs/prefs closer-mop/allegro closer-mop/clisp closer-mop/ecl closer-mop/lispworks closer-mop/mcl closer-mop

Author: hhubner Date: 2007-10-04 15:56:01 -0400 (Thu, 04 Oct 2007) New Revision: 2207

Added: branches/trunk-reorg/thirdparty/closer-mop/ branches/trunk-reorg/thirdparty/closer-mop/_darcs/ branches/trunk-reorg/thirdparty/closer-mop/_darcs/checkpoints/ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/allegro/ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/allegro/closer-mop-packages.lisp branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/allegro/closer-mop.lisp branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/clisp/ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/clisp/closer-mop-packages.lisp branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/clisp/closer-mop.lisp branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/closer-mop-utility-packages.lisp branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/closer-mop.asd branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/ecl/ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/ecl/closer-mop-packages.lisp branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/ecl/closer-mop.lisp branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/features.lisp branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/features.txt branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/lispworks/ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/lispworks/closer-mop-packages.lisp branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/lispworks/closer-mop.lisp branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/mcl/ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/mcl/closer-mop-packages.lisp branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/mcl/closer-mop.lisp branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/pcl/ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/pcl/closer-mop-packages.lisp branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/pcl/closer-mop.lisp branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/release-notes.txt branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/supported-cls.txt branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/test/ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/test/jeffs-code.lisp branches/trunk-reorg/thirdparty/closer-mop/_darcs/inventories/ branches/trunk-reorg/thirdparty/closer-mop/_darcs/inventories/20070421193107-dccf3-e9d51ab58efdffe18510bddafbfa450f276c224f.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/inventory branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/ branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20050802151239-dccf3-e268d42f1d0bfb9c7ef64135393a2f63b243ed54.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20050816144718-dccf3-c8e542ff6d11161f8c50c8595710590711c6732b.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20050816231151-dccf3-e3829cce37824704fb39f3cafdc3c6a92f2d3cf3.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20050904001359-dccf3-914880d9d7054a58ddf886f661065a9352df6e08.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20050910092744-dccf3-87b02abfabbf534e03e82a45a96521a1d7c7a3b2.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20050910103331-dccf3-6311e556632ec0e01cc952b75171e77536716c0c.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20050910110130-dccf3-c6296b87c9e0e39bf7e938444dbd278fbba606c3.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051029013651-dccf3-b4be9c6147a26c1e9767e9951f49aee2c898655b.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051029115614-dccf3-65351c2ca451aceaa696ac89c9c8223199afae00.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051029224040-dccf3-98657977f7a5a7dc1dce7fc2b536413116b1e9cb.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051103084956-dccf3-bc5ad826d6d0c656f1e9f7af023c238ad5a5fade.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051105150436-dccf3-42c062a8ce5e51a74d47911cbf0aed17761f25d3.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051117200922-dccf3-2a2e5386869e5788124740a6796aa8d93fe88a07.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051117201142-dccf3-2700459573f278c02078ef40150f7d92fcb4ed5a.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051117201252-dccf3-5469d4a6ff03e37238daa28708a8727f2f88fdd9.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051130202445-dccf3-d3d97662bf9052129efdf34c4af8cb75d437eb27.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051205134118-dccf3-8045f8a6023f1067bf862213cd46cd07363ce091.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051216174627-3cc5d-3c778eca546a1cdb364885cd436fc275f71cb71e.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051220162014-dccf3-5541c25791f62d836e27802984f53014e2cfc72e.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051228150237-dccf3-fc2c4ab8e8c0798d200109ffc20b79259c28258c.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060103112938-dccf3-2f91b0e195aba3b348283c9c21f36d356db9d32b.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060119133808-dccf3-905164dbf83a727c6875e534c8afc7712adde1e2.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060119133914-dccf3-df1b6582ea4210cf1a697b8c75238342e465d444.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060119202553-dccf3-9e87c4d4d342a8a7fe01167b143ed5e67a08fa8c.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060127142634-dccf3-0cbc9730e904db90c5598f37d28ed2a5d01e8060.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060127142903-dccf3-114489c1437896299eba5cb5e1abcdcee3588f4d.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060127142950-dccf3-a9161a505f3d6fc1376d2e9d065da70c59ec99e2.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060127214635-dccf3-a6d51c1d634b093f9403635cb3ec6230bba703b1.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060201000120-dccf3-b4333796ffe0fe6f5c99603b29cc995508b8dcae.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060201000253-dccf3-6886af50a43d5a624a196f587acf8ef183c6946d.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060201000433-dccf3-825ddee7bae9c308010ec376b13fe5d4038687d5.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060201000511-dccf3-b67c903a0922806dde28834fef9548e1a19450df.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060203120853-dccf3-d772fe3f3f39f4c7114b18ba7dd1ce5c4eaf1896.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060211193158-dccf3-4534d4b849a303f855c692e41232ca1db1c18614.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060216145216-3cc5d-508513582f98be0b13ac28491b590ae926133b98.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060224212121-dccf3-4e71a819e03eb87e7e41b8bbb88758857ff26099.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060224212657-dccf3-068ab07c914a910ead2cf314711aec15c95b3f47.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060301115916-dccf3-319e857c38bf42decd2c98fc3df4208011590dd2.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060301200956-dccf3-d0315e6cf06746cfa4d2f9aae97af7ff6b95f979.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060302093912-dccf3-77419535e33067767884542db7d015cfccb3ac61.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060325171005-dccf3-c26bf0552b60f9e02107614b0fd23b84650b82c6.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060327120633-dccf3-c7f73a665f3f8fcd0d666ae7a08eaa1d586e6be5.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060427163929-dccf3-7c2b0e9aa58e3f5a27375162e099f2c8451137ca.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060501082945-dccf3-f330509c7bf886ad34c63a9fa7386a0a458b34ac.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060529180600-dccf3-62cfd9621e1802d45cd4459d96f367f7a10b5ca1.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060531202150-dccf3-686d5ba89231851614891f21e29033003105888d.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060531203220-dccf3-32e3cf5199ceaf2d34b7b9ed3732e923b6a6de53.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060629175352-dccf3-2a287976284aa6a523d7918f4747cf593174ebe7.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060711121904-dccf3-e427b977f9fa61ac7615b3f9266b3c09f6ab394c.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060720085220-dccf3-8733e01e9790f1929009378878359e13931ff231.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060720105100-dccf3-7d147f9c086e13bd2b83e670953ac124ec7dcb27.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060720105302-dccf3-70b8a60a40352e9ffa430467b36b41d9e785561b.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060721125623-dccf3-c9a6e3c8ab13d7545401922436152ef6039f35b8.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060729125750-dccf3-677f12862b02fb3e369b3855c7a82fc9c9f07e28.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060729134152-dccf3-ee40ebb2ef710ff23053b2765dfd8f5e5adeeb5b.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060729134711-dccf3-dbcf08303fe3f2e8ad195382c90e88cb5fa0fda7.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060729134940-dccf3-c4c1848e22a3d8293090441fd1a1b39670067107.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060729135119-dccf3-62cbac84437b668d5c7b4222d3ffcd9b743a2067.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060729135149-dccf3-615006dc944f3c9c6e15b57467e597f67a40ad77.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060729135435-dccf3-a6554658258dcdada3b08ad08e6dd17657c7c974.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060802122101-dccf3-c0ae6510f6436c0fb88bb5ff92a25c9ae529ad17.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060821203834-dccf3-d6305a3e3412ff99beace007948dafc3100e1d6e.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060826084425-dccf3-1cb35238f9645cd1d5d4e477a9234fc583e0dc6f.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060826103957-dccf3-4bfdc272ae29918f08b54d0bdc14fed29b443814.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060826124935-dccf3-2a4546691b80a18783c5421d46ac3d72a2c252fb.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060826130127-dccf3-eec66c0522b0ab74d72bfdd61250f0ffaae584c6.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060927161258-dccf3-649ad24438070167a2f0100bb9b8f62601147f6d.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061001221204-dccf3-56ed441636d15f7f23de7b76b6be8222fb9b67f8.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061010173021-dccf3-159ee4ddbabc437a75ebf561e3301e92327dadf2.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061010174147-dccf3-d08093855647506dfbfe1c8263a3555f7a08541a.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061013081525-dccf3-fe4c6c81952c166149c00b1fe0df0834743ea370.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061014113836-dccf3-f117c253f5ab3d478f32c411f076a5b9d90f28be.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061028113627-dccf3-5f62832804d6c3dc544bd00341a7551fce46af78.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061031090315-dccf3-42d2030266347debf49e4bf88a13abdcffb4eac1.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061116132730-dccf3-e92c87581e04f60c7a029bbe6d7cdd6958319ff7.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061130202814-dccf3-3120d1936aca4182a1f8fd2e9076e84e1404d7d5.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061130203424-dccf3-74301ed5df59c70046119acac59c5ceef0c00ecf.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061218222443-dccf3-edde41dbcc6152e160bfc02201985e577adc11b0.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061218222546-dccf3-81a4963703b080a4230de18285fcc7f4f8f076a8.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061227142245-dccf3-9eee2aa05227bdf4f4eeaf45e58c845a4707ffff.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228002510-dccf3-163cba8d0d6e4c7548bcac17463887b52d482b11.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228002726-dccf3-2abe813153b4868c6219d045cba84119bbe37b62.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228002856-dccf3-af055d64a95a072906b14cf1713d04f171fae53d.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228003007-dccf3-19d3d52b67d6752806ade229cc573df39fefd736.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228151904-dccf3-ef3232d3763a7a5fcfd18bd92b289590e8dfbb77.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228151916-dccf3-82758310329d2019305d44c787c6ff559720c202.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228161029-dccf3-89435e9661c27dc9251269f3e035574cce8ccc6b.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228161128-dccf3-0adc1e659006165544e9d15583841f321aca1b4e.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070127192325-dccf3-d77060b4d6264e601b0a0456c59bc0f9b6b39d42.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070127192925-dccf3-0f0f5a0c26d9089334b2f54ae13cea2ddc4cd881.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070127195002-dccf3-314892775fb8ae67ee688777168326daba80b565.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070127201814-dccf3-128f7776110f2b6673a72a9e5c97d3a090cd028f.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070206104737-dccf3-e8605c338153ef4cfca23e2691bdbd8220ed9c17.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070228193530-dccf3-b0fe50e904a9f06b680ab19c79d5e375c45bb4e1.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070327202949-dccf3-77b1abaa2cd6661419f04d3c1422ee0e4970e2d5.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070421192516-dccf3-13d712262e80609ffa3e44656a11ddf1eb8c5ba2.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070421193020-dccf3-46cccd00d206b252681348edde6d08b9f8c12744.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070421193107-dccf3-e9d51ab58efdffe18510bddafbfa450f276c224f.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070501115057-dccf3-fd3901cf565e463eddafaf82e6f526d9403f5f29.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070528145132-dccf3-e1d978c1cd424af7cfabb1d036d07a10a7a4ed62.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070628201619-dccf3-6697990e3daa875937fba6209b49f9700ce5f98f.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070831233438-dccf3-551d9afcedf44d0735b330c50be407619f4cb8e0.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070916181018-dccf3-e11c738d92d8e1b2dbc979a10f258a647e164022.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070926164316-dccf3-0399c8966f70466f0bb3f1abd28f14b7698f542f.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070926172622-dccf3-0c2318248afb60197e6986c33794e0f97e43cfa2.gz branches/trunk-reorg/thirdparty/closer-mop/_darcs/prefs/ branches/trunk-reorg/thirdparty/closer-mop/_darcs/prefs/binaries branches/trunk-reorg/thirdparty/closer-mop/_darcs/prefs/boring branches/trunk-reorg/thirdparty/closer-mop/_darcs/prefs/defaultrepo branches/trunk-reorg/thirdparty/closer-mop/_darcs/prefs/motd branches/trunk-reorg/thirdparty/closer-mop/_darcs/prefs/repos branches/trunk-reorg/thirdparty/closer-mop/allegro/ branches/trunk-reorg/thirdparty/closer-mop/allegro/closer-mop-packages.lisp branches/trunk-reorg/thirdparty/closer-mop/allegro/closer-mop.lisp branches/trunk-reorg/thirdparty/closer-mop/clisp/ branches/trunk-reorg/thirdparty/closer-mop/clisp/closer-mop-packages.lisp branches/trunk-reorg/thirdparty/closer-mop/clisp/closer-mop.lisp branches/trunk-reorg/thirdparty/closer-mop/closer-mop-utility-packages.lisp branches/trunk-reorg/thirdparty/closer-mop/closer-mop.asd branches/trunk-reorg/thirdparty/closer-mop/ecl/ branches/trunk-reorg/thirdparty/closer-mop/ecl/closer-mop-packages.lisp branches/trunk-reorg/thirdparty/closer-mop/ecl/closer-mop.lisp branches/trunk-reorg/thirdparty/closer-mop/features.lisp branches/trunk-reorg/thirdparty/closer-mop/features.txt branches/trunk-reorg/thirdparty/closer-mop/lispworks/ branches/trunk-reorg/thirdparty/closer-mop/lispworks/closer-mop-packages.lisp branches/trunk-reorg/thirdparty/closer-mop/lispworks/closer-mop.lisp branches/trunk-reorg/thirdparty/closer-mop/mcl/ branches/trunk-reorg/thirdparty/closer-mop/mcl/closer-mop-packages.lisp branches/trunk-reorg/thirdparty/closer-mop/mcl/closer-mop.lisp branches/trunk-reorg/thirdparty/closer-mop/pcl/ branches/trunk-reorg/thirdparty/closer-mop/pcl/closer-mop-packages.lisp branches/trunk-reorg/thirdparty/closer-mop/pcl/closer-mop.lisp branches/trunk-reorg/thirdparty/closer-mop/release-notes.txt branches/trunk-reorg/thirdparty/closer-mop/supported-cls.txt branches/trunk-reorg/thirdparty/closer-mop/test/ branches/trunk-reorg/thirdparty/closer-mop/test/jeffs-code.lisp branches/trunk-reorg/thirdparty/lw-compat/ branches/trunk-reorg/thirdparty/lw-compat/_darcs/ branches/trunk-reorg/thirdparty/lw-compat/_darcs/checkpoints/ branches/trunk-reorg/thirdparty/lw-compat/_darcs/current/ branches/trunk-reorg/thirdparty/lw-compat/_darcs/current/lw-compat-package.lisp branches/trunk-reorg/thirdparty/lw-compat/_darcs/current/lw-compat.asd branches/trunk-reorg/thirdparty/lw-compat/_darcs/current/lw-compat.lisp branches/trunk-reorg/thirdparty/lw-compat/_darcs/inventories/ branches/trunk-reorg/thirdparty/lw-compat/_darcs/inventories/20060826123920-dccf3-4b37fa484f969eb9c3837a020e32b42e33f4cef6.gz branches/trunk-reorg/thirdparty/lw-compat/_darcs/inventory branches/trunk-reorg/thirdparty/lw-compat/_darcs/patches/ branches/trunk-reorg/thirdparty/lw-compat/_darcs/patches/20050802152818-dccf3-9ba8553d2b62c698e6208680ab099ea6273a7458.gz branches/trunk-reorg/thirdparty/lw-compat/_darcs/patches/20050811150118-dccf3-9db8fc99fbfbac77dda86fa3ca80f0f92c0f054b.gz branches/trunk-reorg/thirdparty/lw-compat/_darcs/patches/20051228220551-dccf3-bec704780b86cf94b4f443e53d52d8e46f8ab139.gz branches/trunk-reorg/thirdparty/lw-compat/_darcs/patches/20060821203626-dccf3-a75c8e2b513b571a43ce6c5e8dd377b2bca40887.gz branches/trunk-reorg/thirdparty/lw-compat/_darcs/patches/20060826123920-dccf3-4b37fa484f969eb9c3837a020e32b42e33f4cef6.gz branches/trunk-reorg/thirdparty/lw-compat/_darcs/patches/20060826125726-dccf3-b9ca9d92f93eefe4744f2275eaf40b6702e5b743.gz branches/trunk-reorg/thirdparty/lw-compat/_darcs/patches/20060918174843-dccf3-641503d97f1447c7cf67b79d9d0e557fe35e4dfa.gz branches/trunk-reorg/thirdparty/lw-compat/_darcs/prefs/ branches/trunk-reorg/thirdparty/lw-compat/_darcs/prefs/binaries branches/trunk-reorg/thirdparty/lw-compat/_darcs/prefs/boring branches/trunk-reorg/thirdparty/lw-compat/_darcs/prefs/defaultrepo branches/trunk-reorg/thirdparty/lw-compat/_darcs/prefs/motd branches/trunk-reorg/thirdparty/lw-compat/_darcs/prefs/repos branches/trunk-reorg/thirdparty/lw-compat/lw-compat-package.lisp branches/trunk-reorg/thirdparty/lw-compat/lw-compat.asd branches/trunk-reorg/thirdparty/lw-compat/lw-compat.lisp Log: adding new libs

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/allegro/closer-mop-packages.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/allegro/closer-mop-packages.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/allegro/closer-mop-packages.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,190 @@ +(in-package :cl-user) + +(defpackage #:closer-mop + (:use #:common-lisp #:lispworks) + (:nicknames #:c2mop) + + (:shadow + #:defclass #:defgeneric #:ensure-generic-function + #:standard-class #:standard-generic-function) + (:export + #:defclass #:defgeneric #:ensure-generic-function + #:standard-class #:standard-generic-function) + + (:import-from #:mop + + #:direct-slot-definition + #:effective-slot-definition + #:eql-specializer + #:forward-referenced-class + #:funcallable-standard-class + #:funcallable-standard-object + #:metaobject + #:slot-definition + #:specializer + #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + + #:accessor-method-slot-definition + #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #:eql-specializer-object + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #:find-method-combination + #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #:intern-eql-specializer + #-allegro #:make-method-lambda + #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #:reader-method-class + #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #:specializer-direct-generic-functions + #:specializer-direct-methods + #:standard-instance-access + #:update-dependent + #:validate-superclass + #:writer-method-class) + + (:export + #:direct-slot-definition + #:effective-slot-definition + #:eql-specializer + #:forward-referenced-class + #:funcallable-standard-class + #:funcallable-standard-object + #:metaobject + #:slot-definition + #:specializer + #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + + #:ensure-finalized + #:ensure-method + #:fix-slot-initargs + #:required-args + + #:accessor-method-slot-definition + #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #:eql-specializer-object + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #:find-method-combination + #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #:intern-eql-specializer + #-allegro #:make-method-lambda + #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #:reader-method-class + #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #:specializer-direct-generic-functions + #:specializer-direct-methods + #:standard-instance-access + #:update-dependent + #:validate-superclass + #:writer-method-class))

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/allegro/closer-mop.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/allegro/closer-mop.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/allegro/closer-mop.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,197 @@ +(in-package :closer-mop) + +;; Some utility functions. + +(defun required-args (lambda-list &optional (collector #'identity)) + (loop for arg in lambda-list + until (member arg lambda-list-keywords) + collect (funcall collector arg))) + +(defun ensure-finalized (class &optional (errorp t)) + (if (typep class 'class) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (when errorp (error "~S is not a class." class))) + class) + +;; We need a new standard-class for various things. + +(cl:defclass standard-class (cl:standard-class) + ((valid-slot-allocations :initform '(:instance :class) + :accessor valid-slot-allocations + :reader excl::valid-slot-allocation-list))) + +;; validate-superclass for metaclass classes is a little bit +;; more tricky than for class metaobject classes because +;; we don't want to make all standard-classes compatible to +;; each other. + +;; Our validate-superclass may get passed a class-prototype +;; as its second argument, so don't expect its readers to +;; yield useful information. (In ANSI parlance, "the +;; consequences are undefined...") + +(cl:defmethod validate-superclass + ((class standard-class) + (superclass cl:standard-class)) + (or (when (eq (class-of class) (find-class 'standard-class)) + (or (eq (class-of superclass) (find-class 'cl:standard-class)) + (eq (class-of superclass) (find-class 'standard-class)))) + (call-next-method) + (when (eq (class-of superclass) (find-class 'cl:standard-class)) + (validate-superclass class (class-prototype (find-class 'standard-class)))))) + +;; The following macro ensures that the new standard-class is used by default. + +(defmacro defclass (name (&rest supers) &body options) + (if (member :metaclass options :key #'car) + `(cl:defclass ,name ,supers ,@options) + `(cl:defclass ,name ,supers ,@options + (:metaclass standard-class)))) + +;; Allegro defines an extra check for :allocation kinds. AMOP expects any kind to be +;; permissible, though. This is corrected here. + +(defmethod direct-slot-definition-class :before ((class standard-class) &key allocation &allow-other-keys) + (unless (eq (class-of class) (find-class 'standard-class)) + (pushnew allocation (valid-slot-allocations class)))) + +;;; In Allegro, slot-boundp-using-class and slot-makunbound-using-class are specialized +;;; on slot names instead of effective slot definitions. In order to fix this, +;;; we need to rewire the slot access protocol. + +#-(version>= 8 1) +(progn + (cl:defmethod slot-boundp-using-class + ((class standard-class) object (slot symbol)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (let ((slotd (find slot (class-slots class) + :test #'eq + :key #'slot-definition-name))) + (if slotd + (slot-boundp-using-class class object slotd) + (slot-missing class object slot 'slot-boundp)))) + + (cl:defmethod slot-boundp-using-class + ((class standard-class) object (slotd standard-effective-slot-definition)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (slot-boundp-using-class + (load-time-value (class-prototype (find-class 'cl:standard-class))) + object + (slot-definition-name slotd)))) + +(cl:defmethod slot-makunbound-using-class + ((class standard-class) object (slot symbol)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (let ((slotd (find slot (class-slots class) + :test #'eq + :key #'slot-definition-name))) + (if slotd + (slot-makunbound-using-class class object slotd) + (slot-missing class object slot 'slot-makunbound)))) + +(cl:defmethod slot-makunbound-using-class + ((class standard-class) object (slotd standard-effective-slot-definition)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (slot-makunbound-using-class + (load-time-value (class-prototype (find-class 'cl:standard-class))) + object + (slot-definition-name slotd))) + +;; We need a new standard-generic-function for various things. + +(cl:defclass standard-generic-function (cl:standard-generic-function) + () + (:metaclass clos:funcallable-standard-class)) + +;; The following ensures that the new standard-generic-function is used. + +(defun ensure-generic-function + (name &rest args + &key (generic-function-class 'standard-generic-function) + &allow-other-keys) + (declare (dynamic-extent args)) + (when (fboundp name) + (let ((function (fdefinition name))) + (unless (typep function 'generic-function) + (cerror "Discard existing definition and create generic function." + "~S is already fbound, but not as a generic function." name) + (fmakunbound name)))) + (if (fboundp name) + (let ((function (fdefinition name))) + (apply #'ensure-generic-function-using-class + function name args)) + (apply #'ensure-generic-function-using-class nil name + :generic-function-class generic-function-class + args))) + +;; The following macro ensures that the new standard-generic-function +;; is used by default. + +(defmacro defgeneric (name (&rest args) &body options) + (if (member :generic-function-class options :key #'car) + `(cl:defgeneric ,name ,args ,@options) + `(cl:defgeneric ,name ,args ,@options + (:generic-function-class standard-generic-function)))) + +;;; The following three methods ensure that the dependent protocol +;;; for generic function works. + +;; The following method additionally ensures that +;; compute-discriminating-function is triggered. + +(cl:defmethod reinitialize-instance :after + ((gf standard-generic-function) &rest initargs) + (declare (dynamic-extent initargs)) + (set-funcallable-instance-function + gf (compute-discriminating-function gf)) + (map-dependents + gf (lambda (dep) (apply #'update-dependent gf dep initargs)))) + +(cl:defmethod add-method :after + ((gf standard-generic-function) method) + (map-dependents + gf (lambda (dep) (update-dependent gf dep 'add-method method)))) + +(cl:defmethod remove-method :after + ((gf standard-generic-function) method) + (map-dependents + gf (lambda (dep) (update-dependent gf dep 'remove-method method)))) + +(defun ensure-method (gf lambda-expression + &key (qualifiers ()) + (lambda-list (cadr lambda-expression)) + (specializers (required-args lambda-list (constantly (find-class 't))))) + (funcall (compile nil `(lambda () + (defmethod ,(generic-function-name gf) ,@qualifiers + ,(loop for specializer in specializers + for (arg . rest) on lambda-list + collect `(,arg ,specializer) into args + finally (return (nconc args rest))) + ,@(cddr lambda-expression)))))) + +;; The following can be used in direct-slot-definition-class to get the correct initargs +;; for a slot. Use it like this: +;; +;; (defmethod direct-slot-definition-class +;; ((class my-standard-class) &rest initargs) +;; (declare (dynamic-extent initargs)) +;; (destructuring-bind +;; (&key key-of-interest &allow-other-keys) +;; (fix-slot-initargs initargs) +;; ...)) + +(defvar *standard-slot-keys* + '(:name :documentation + :initargs :initform :initfunction + :readers :writers)) + +(defun fix-slot-initargs (initargs) + initargs) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew :closer-mop *features*))

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/clisp/closer-mop-packages.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/clisp/closer-mop-packages.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/clisp/closer-mop-packages.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,183 @@ +(in-package :cl-user) + +(defpackage #:closer-mop + (:use #:common-lisp #:lispworks) + (:nicknames #:c2mop) + + (:import-from #:clos + + #:direct-slot-definition + #:effective-slot-definition + #:eql-specializer + #:forward-referenced-class + #:funcallable-standard-class + #:funcallable-standard-object + #:metaobject + #:slot-definition + #:specializer + #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + + #:accessor-method-slot-definition + #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #:eql-specializer-object + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #:find-method-combination + #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #:intern-eql-specializer + #-clisp #:make-method-lambda + #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #:reader-method-class + #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #:specializer-direct-generic-functions + #:specializer-direct-methods + #:standard-instance-access + #:update-dependent + #:validate-superclass + #:writer-method-class) + + (:export + #:direct-slot-definition + #:effective-slot-definition + #:eql-specializer + #:forward-referenced-class + #:funcallable-standard-class + #:funcallable-standard-object + #:metaobject + #:slot-definition + #:specializer + #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + + #:ensure-finalized + #:ensure-method + #:fix-slot-initargs + #:required-args + + #:accessor-method-slot-definition + #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #:eql-specializer-object + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #:find-method-combination + #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #:intern-eql-specializer + #-clisp #:make-method-lambda + #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #:reader-method-class + #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #:specializer-direct-generic-functions + #:specializer-direct-methods + #:standard-instance-access + #:update-dependent + #:validate-superclass + #:writer-method-class))

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/clisp/closer-mop.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/clisp/closer-mop.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/clisp/closer-mop.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,49 @@ +(in-package :closer-mop) + +;; Some utility functions. + +(defun required-args (lambda-list &optional (collector #'identity)) + (loop for arg in lambda-list + until (member arg lambda-list-keywords) + collect (funcall collector arg))) + +(defun ensure-finalized (class &optional (errorp t)) + (if (typep class 'class) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (when errorp (error "~S is not a class." class))) + class) + +(defun ensure-method (gf lambda-expression + &key (qualifiers ()) + (lambda-list (cadr lambda-expression)) + (specializers (required-args lambda-list (constantly 't)))) + (funcall (compile nil `(lambda () + (defmethod ,(generic-function-name gf) ,@qualifiers + ,(loop for specializer in specializers + for (arg . rest) on lambda-list + collect `(,arg ,specializer) into args + finally (return (nconc args rest))) + ,@(cddr lambda-expression)))))) + +;; The following can be used in direct-slot-definition-class to get the correct initargs +;; for a slot. Use it like this: +;; +;; (defmethod direct-slot-definition-class +;; ((class my-standard-class) &rest initargs) +;; (declare (dynamic-extent initargs)) +;; (destructuring-bind +;; (&key key-of-interest &allow-other-keys) +;; (fix-slot-initargs initargs) +;; ...)) + +(defvar *standard-slot-keys* + '(:name :documentation + :initargs :initform :initfunction + :readers :writers)) + +(defun fix-slot-initargs (initargs) + initargs) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew :closer-mop *features*))

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/closer-mop-utility-packages.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/closer-mop-utility-packages.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/closer-mop-utility-packages.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,18 @@ +(in-package :cl-user) + +(defpackage #:closer-common-lisp + (:nicknames #:c2cl) + (:use)) + +(let ((syms (nunion (loop for sym being the external-symbols of :common-lisp + if (find-symbol (symbol-name sym) :c2mop) + collect it + else collect sym) + (loop for sym being the external-symbols of :c2mop + collect sym)))) + (import syms :c2cl) + (export syms :c2cl)) + +(defpackage #:closer-common-lisp-user + (:nicknames #:c2cl-user) + (:use #:closer-common-lisp))

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/closer-mop.asd =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/closer-mop.asd 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/closer-mop.asd 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,47 @@ +(asdf:defsystem #:closer-mop + :name "Closer to MOP" + :author "Pascal Costanza" + :version "0.42" + :licence " +Copyright (c) 2005 - 2007 Pascal Costanza + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, sublicense, and/or +sell copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. +" + :depends-on (#-lispworks #:lw-compat) + :components + ((:module + #+allegro "allegro" + #+clisp "clisp" + #+ecl "ecl" + #+lispworks "lispworks" + #+(or mcl openmcl) "mcl" + #+(or cmu sbcl) "pcl" + :components ((:file "closer-mop-packages") + (:file "closer-mop" + :depends-on ("closer-mop-packages")))) + (:file "closer-mop-utility-packages" + :depends-on (#+allegro "allegro" + #+clisp "clisp" + #+ecl "ecl" + #+lispworks "lispworks" + #+(or mcl openmcl) "mcl" + #+(or cmu sbcl) "pcl"))))

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/ecl/closer-mop-packages.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/ecl/closer-mop-packages.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/ecl/closer-mop-packages.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,190 @@ +(in-package :cl-user) + +(defpackage #:closer-mop + (:use #:common-lisp #:lispworks) + (:nicknames #:c2mop) + + (:shadow #:defgeneric #:ensure-generic-function #:find-method + #:remove-method #:standard-generic-function) + (:export #:defgeneric #:ensure-generic-function #:find-method + #:remove-method #:standard-generic-function) + + (:import-from #:clos + + #:direct-slot-definition + #:effective-slot-definition + #-ecl #:eql-specializer + #:forward-referenced-class + #-ecl #:funcallable-standard-class + #-ecl #:funcallable-standard-object + #-ecl #:metaobject + #:slot-definition + #-ecl #:specializer + #-ecl #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #-ecl #:standard-reader-method + #:standard-slot-definition + #-ecl #:standard-writer-method + + #-ecl #:accessor-method-slot-definition + #-ecl #:add-dependent + #-ecl #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #-ecl #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #-ecl #:eql-specializer-object + #-ecl #:extract-lambda-list + #-ecl #:extract-specializer-names + #:finalize-inheritance + #-ecl #:find-method-combination + #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #-ecl #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #-ecl #:intern-eql-specializer + #-ecl #:make-method-lambda + #-ecl #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #-ecl #:reader-method-class + #-ecl #:remove-dependent + #-ecl #:remove-direct-method + #:remove-direct-subclass + #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #-ecl #:specializer-direct-generic-functions + #-ecl #:specializer-direct-methods + #:standard-instance-access + #-ecl #:update-dependent + #-ecl #:validate-superclass + #-ecl #:writer-method-class) + + (:export + #:direct-slot-definition + #:effective-slot-definition + #:eql-specializer + #:forward-referenced-class + #-ecl #:funcallable-standard-class + #-ecl #:funcallable-standard-object + #-ecl #:metaobject + #:slot-definition + #-ecl #:specializer + #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + + #:ensure-finalized + #:ensure-method + #:fix-slot-initargs + #:required-args + + #:accessor-method-slot-definition + #-ecl #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #-ecl #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #:eql-specializer-object + #:eql-specializer-object* + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #-ecl #:find-method-combination + #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #-ecl #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #:intern-eql-specializer + #:intern-eql-specializer* + #-ecl #:make-method-lambda + #-ecl #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #:reader-method-class + #-ecl #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #:specializer-direct-generic-functions + #:specializer-direct-methods + #:standard-instance-access + #-ecl #:update-dependent + #-ecl #:validate-superclass + #:writer-method-class))

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/ecl/closer-mop.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/ecl/closer-mop.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/ecl/closer-mop.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,312 @@ +(in-package :closer-mop) + +;; Some utility functions. + +(defun required-args (lambda-list &optional (collector #'identity)) + (loop for arg in lambda-list + until (member arg lambda-list-keywords) + collect (funcall collector arg))) + +(defun ensure-finalized (class &optional (errorp t)) + (if (typep class 'class) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (when errorp (error "~S is not a class." class))) + class) + +(defun extract-lambda-list (lambda-list) + (loop for (arg . rest) on lambda-list + until (member arg lambda-list-keywords) + if (consp arg) + collect (car arg) into args + else collect arg into args + finally (return (if arg + (nconc args (cons arg rest)) + args)))) + +(defun extract-specializer-names (lambda-list) + (loop for arg in lambda-list + until (member arg lambda-list-keywords) + if (consp arg) + collect (cadr arg) + else collect 't)) + +;; We need a new standard-generic-function for various things. + +(cl:defclass standard-generic-function (cl:standard-generic-function) + ()) + +;; The following ensures that the new standard-generic-function is used. + +(defun ensure-generic-function + (name &rest args + &key (generic-function-class 'standard-generic-function) + &allow-other-keys) + (declare (dynamic-extent args)) + (apply #'cl:ensure-generic-function name + :generic-function-class generic-function-class + args)) + +#| +(defun ensure-generic-function + (name &rest args + &key (generic-function-class 'standard-generic-function) + &allow-other-keys) + (declare (dynamic-extent args)) + (when (fboundp name) + (let ((function (fdefinition name))) + (unless (typep function 'generic-function) + (cerror "Discard existing definition and create generic function." + "~S is already fbound, but not as a generic function." name) + (fmakunbound name)))) + (if (fboundp name) + (let ((function (fdefinition name))) + (apply #'ensure-generic-function-using-class + function name args)) + (apply #'ensure-generic-function-using-class nil name + :generic-function-class generic-function-class + args))) +|# + +;; The standard accessor classes. + +(cl:defclass standard-accessor-method (standard-method) + ((slotd :initarg :slot-definition + :reader accessor-method-slot-definition))) + +(cl:defclass standard-reader-method (standard-accessor-method) + ()) + +(cl:defclass standard-writer-method (standard-accessor-method) + ()) + +;; In ECL, reader-method-class and writer-method-class are +;; not used during class initialization. The following definitions +;; correct this. + +(cl:defgeneric reader-method-class (class slot-definition &rest initargs) + (:method ((class class) slot-definition &rest initargs) + (declare (ignore slot-definition initargs)) + (load-time-value (find-class 'standard-reader-method)))) + +(cl:defgeneric writer-method-class (class slot-definition &rest initargs) + (:method ((class class) slot-definition &rest initargs) + (declare (ignore slot-definition initargs)) + (load-time-value (find-class 'standard-writer-method)))) + +(cl:defgeneric find-method (gf qualifiers specializers &optional errorp) + (:method ((gf generic-function) qualifiers specializers &optional (errorp t)) + (cl:find-method gf qualifiers specializers errorp))) + +(defun modify-accessors (class) + (loop with reader-specializers = (list class) + with writer-specializers = (list (find-class 't) class) + for slotd in (class-direct-slots class) do + (loop for reader in (slot-definition-readers slotd) + for reader-function = (fdefinition reader) + for reader-method = (find-method reader-function () reader-specializers) + for initargs = (list :qualifiers () + :lambda-list '(object) + :specializers reader-specializers + :function (method-function reader-method) + :slot-definition slotd) + for method-class = (apply #'reader-method-class class slotd initargs) + unless (eq method-class (class-of reader-method)) + do (add-method reader-function (apply #'make-instance method-class initargs))) + (loop for writer in (slot-definition-writers slotd) + for writer-function = (fdefinition writer) + for writer-method = (find-method writer-function () writer-specializers) + for initargs = (list :qualifiers () + :lambda-list '(new-value object) + :specializers writer-specializers + :function (method-function writer-method) + :slot-definition slotd) + for method-class = (apply #'writer-method-class class slotd initargs) + unless (eq method-class (class-of writer-method)) + do (add-method writer-function (apply #'make-instance method-class initargs))))) + +;; During class re/initialization, we take care of the following things: +;; - Optimization of slot accessors is deactivated. +;; - Removal of direct subclasses. + +(cl:defmethod initialize-instance :around + ((class standard-class) &rest initargs) + (declare (dynamic-extent initargs)) + (prog1 (apply #'call-next-method class + :optimize-slot-access nil + initargs) + (modify-accessors class))) + +(cl:defmethod reinitialize-instance :around + ((class standard-class) &rest initargs + &key (direct-superclasses () direct-superclasses-p)) + (declare (dynamic-extent initargs)) + (when direct-superclasses-p + (loop for superclass in (copy-list (class-direct-superclasses class)) + unless (member superclass direct-superclasses) + do (remove-direct-subclass superclass class))) + (prog1 (apply #'call-next-method class + :optimize-slot-access nil + initargs) + (modify-accessors class))) + +;; In ECL, eql specializers are lists. We cannot change this +;; but we can soften some of the incompatibilities. + +(defun eql-specializer-p (cons) + (and (consp cons) + (eq (car cons) 'eql) + (null (cddr cons)))) + +(deftype eql-specializer () + '(or eql-specializer* + (satisfies eql-specializer-p))) + +(cl:defgeneric eql-specializer-object (eql-specializer) + (:method ((cons cons)) + (if (eql-specializer-p cons) + (cadr cons) + (error "~S is not an eql-specializer." cons)))) + +(defun intern-eql-specializer (object) + `(eql ,object)) + +(cl:defgeneric specializer-direct-methods (specializer)) + +(cl:defclass eql-specializer* (standard-object) + ((obj :reader eql-specializer-object + :initarg eso + :initform (error "Use intern-eql-specializer to create eql-specializers.")) + (direct-methods :reader specializer-direct-methods + :accessor es-direct-methods + :initform ()))) + +(defvar *eql-specializers* (make-hash-table)) + +(defun intern-eql-specializer* (object) + (or (gethash object *eql-specializers*) + (setf (gethash object *eql-specializers*) + (make-instance 'eql-specializer* 'eso object)))) + +(defvar *direct-methods* (make-hash-table :test #'eq)) + +(cl:defgeneric add-direct-method (specializer method) + (:method ((specializer class) (method method)) + (pushnew method (gethash specializer *direct-methods*))) + (:method ((specializer eql-specializer*) (method method)) + (pushnew method (es-direct-methods specializer)))) + +(cl:defgeneric remove-direct-method (specializer method) + (:method ((specializer class) (method method)) + (removef (gethash specializer *direct-methods*) method)) + (:method ((specializer eql-specializer*) (method method)) + (removef (es-direct-methods specializer) method))) + +(cl:defmethod specializer-direct-methods ((class class)) + (gethash class *direct-methods*)) + +(cl:defgeneric specializer-direct-generic-functions (specializer) + (:method ((class class)) + (remove-duplicates + (mapcar #'method-generic-function + (specializer-direct-methods class)))) + (:method ((eql-specializer eql-specializer*)) + (remove-duplicates + (mapcar #'method-generic-function + (specializer-direct-methods eql-specializer)))) + (:method ((cons cons)) + (specializer-direct-generic-functions + (intern-eql-specializer* + (eql-specializer-object cons))))) + +;; The following method ensures that remove-method is called. + +(cl:defmethod add-method :before ((gf standard-generic-function) (method method)) + (when-let (old-method (find-method gf (method-qualifiers method) + (method-specializers method) nil)) + (remove-method gf old-method))) + +;; The following two methods ensure that add/remove-direct-method is called, +;; and that the dependent protocol for generic function works. + +(cl:defmethod add-method :after ((gf standard-generic-function) (method method)) + (loop for specializer in (method-specializers method) + do (add-direct-method + (if (consp specializer) + (intern-eql-specializer* + (eql-specializer-object specializer)) + specializer) + method))) + +(cl:defgeneric remove-method (generic-function method) + (:method ((gf generic-function) (method method)) + (cl:remove-method gf method))) + +(cl:defmethod remove-method :after ((gf generic-function) (method method)) + (loop for specializer in (method-specializers method) + do (remove-direct-method + (if (consp specializer) + (intern-eql-specializer* + (eql-specializer-object specializer)) + specializer) + method))) + +(defun ensure-method (gf lambda-expression + &key (qualifiers ()) + (lambda-list (cadr lambda-expression)) + (specializers (required-args lambda-list (constantly (find-class 't))))) + (funcall (compile nil `(lambda () + (defmethod ,(generic-function-name gf) ,@qualifiers + ,(loop for specializer in specializers + for (arg . rest) on lambda-list + collect `(,arg ,specializer) into args + finally (return (nconc args rest))) + ,@(cddr lambda-expression)))))) + +(defmacro defgeneric (&whole form name (&rest args) &body options) + (unless (every #'consp options) + (error "Illegal generic functions options in defgeneric form ~S." form)) + `(cl:defgeneric ,name ,args + ,@options + ,@(unless (member :generic-function-class options :key #'car :test #'eq) + '((:generic-function-class standard-generic-function))))) + +;; The following can be used in direct-slot-definition-class to get the correct initargs +;; for a slot. Use it like this: +;; +;; (defmethod direct-slot-definition-class +;; ((class my-standard-class) &rest initargs) +;; (declare (dynamic-extent initargs)) +;; (destructuring-bind +;; (&key key-of-interest &allow-other-keys) +;; (fix-slot-initargs initargs) +;; ...)) + +(defvar *standard-slot-keys* + '(:name :documentation + :initargs :initform :initfunction + :readers :writers)) + +(defun fix-slot-initargs (initargs) + (let* ((counts (loop with counts + for (key nil) on initargs by #'cddr + do (incf (getf counts key 0)) + finally (return counts))) + (keys-to-fix (loop for (key value) on counts by #'cddr + if (> value 1) collect key))) + (if keys-to-fix + (let ((multiple-standard-keys + (intersection keys-to-fix *standard-slot-keys*))) + (if multiple-standard-keys + (error "Too many occurences of ~S in slot initargs ~S." + multiple-standard-keys initargs) + (loop with fixed-keys + for (key value) on initargs by #'cddr + if (member key keys-to-fix) + do (nconcf (getf fixed-keys key) (list value)) + else nconc (list key value) into fixed-initargs + finally (return (nconc fixed-initargs fixed-keys))))) + initargs))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew :closer-mop *features*))

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/features.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/features.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/features.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,498 @@ + +:allegro7.0 +((:class-default-initargs) + (:class-direct-default-initargs) + (:compute-default-initargs) ; -> :compute-default-initargs-allegro + (:default-superclass-for-funcallable-standard-class-is-funcallable-standard-object) + (:defgeneric-calls-find-method-combination) + (:defmethod-calls-make-method-lambda) + (:dependent-protocol-for-generic-functions fixed) + (:extensible-allocation fixed) + (:function-invocation-calls-compute-applicable-methods) + (:function-invocation-calls-compute-applicable-methods-using-classes) + (:function-invocation-calls-compute-effective-method) + (:make-method-lambda) + (:method-functions-take-processed-parameters) + (:method-lambdas-are-processed) + (:multiple-qualifiers) + (:reinitialize-instance-calls-compute-discriminating-function fixed) + (:setf-class-name-calls-reinitialize-instance) + (:setf-generic-function-name-calls-reinitialize-instance) + (:slot-boundp-using-class-specialized-on-slot-definition fixed) + (:slot-makunbound-using-class-specialized-on-slot-definition fixed) + (:standard-class-and-funcallable-standard-class-are-compatible) + (:subclasses-of-built-in-class-do-not-inherit-exported-slots) + (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots) + (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots) + (:subclasses-of-method-combination-do-not-inherit-exported-slots) + (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-class-do-not-inherit-exported-slots) + (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) + (:subclasses-of-standard-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots) + (:t-is-always-a-valid-superclass)) + +:allegro8.0 +((:class-default-initargs) + (:class-direct-default-initargs) + (:compute-default-initargs) ; -> :compute-default-initargs-allegro + (:default-superclass-for-funcallable-standard-class-is-funcallable-standard-object) + (:defgeneric-calls-find-method-combination) + (:defmethod-calls-make-method-lambda) + (:dependent-protocol-for-generic-functions fixed) + (:extensible-allocation fixed) + (:function-invocation-calls-compute-applicable-methods) + (:function-invocation-calls-compute-applicable-methods-using-classes) + (:function-invocation-calls-compute-effective-method) + (:make-method-lambda) + (:method-functions-take-processed-parameters) + (:method-lambdas-are-processed) + (:reinitialize-instance-calls-compute-discriminating-function fixed) + (:setf-class-name-calls-reinitialize-instance) + (:setf-generic-function-name-calls-reinitialize-instance) + (:slot-boundp-using-class-specialized-on-slot-definition fixed) + (:slot-makunbound-using-class-specialized-on-slot-definition fixed) + (:standard-class-and-funcallable-standard-class-are-compatible) + (:subclasses-of-built-in-class-do-not-inherit-exported-slots) + (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots) + (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots) + (:subclasses-of-method-combination-do-not-inherit-exported-slots) + (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-class-do-not-inherit-exported-slots) + (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) + (:subclasses-of-standard-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots) + (:t-is-always-a-valid-superclass)) + +:allegro8.1 +((:class-default-initargs) + (:class-direct-default-initargs) + (:compute-default-initargs) ; -> :compute-default-initargs-allegro + (:default-superclass-for-funcallable-standard-class-is-funcallable-standard-object) + (:defgeneric-calls-find-method-combination) + (:defmethod-calls-make-method-lambda) + (:dependent-protocol-for-generic-functions fixed) + (:extensible-allocation fixed) + (:function-invocation-calls-compute-applicable-methods) + (:function-invocation-calls-compute-applicable-methods-using-classes) + (:function-invocation-calls-compute-effective-method) + (:make-method-lambda) + (:method-functions-take-processed-parameters) + (:method-lambdas-are-processed) + (:reinitialize-instance-calls-compute-discriminating-function fixed) + (:setf-class-name-calls-reinitialize-instance) + (:setf-generic-function-name-calls-reinitialize-instance) + (:slot-makunbound-using-class-specialized-on-slot-definition fixed) + (:standard-class-and-funcallable-standard-class-are-compatible) + (:subclasses-of-built-in-class-do-not-inherit-exported-slots) + (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots) + (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots) + (:subclasses-of-method-combination-do-not-inherit-exported-slots) + (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-class-do-not-inherit-exported-slots) + (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) + (:subclasses-of-standard-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots) + (:t-is-always-a-valid-superclass)) + +:clisp2.35-2.36 +((:accessor-method-initialized-with-function) + (:add-method-calls-compute-discriminating-function) + (:compute-slots-requested-slot-order-honoured) + (:defmethod-calls-make-method-lambda) + (:extensible-allocation) + (:forward-referenced-class-changed-by-change-class) + (:initialize-instance-calls-compute-discriminating-function) + (:make-method-lambda) + (:method-initialized-with-function) + (:method-lambdas-are-processed) + (:reinitialize-instance-calls-compute-discriminating-function) + (:reinitialize-instance-calls-finalize-inheritance) + (:remove-method-calls-compute-discriminating-function) + (:subclasses-of-method-combination-do-not-inherit-exported-slots)) + +:clisp2.37-2.39 +((:accessor-method-initialized-with-function) + (:add-method-calls-compute-discriminating-function) + (:compute-slots-requested-slot-order-honoured) + (:defmethod-calls-make-method-lambda) + (:forward-referenced-class-changed-by-change-class) + (:initialize-instance-calls-compute-discriminating-function) + (:make-method-lambda) + (:method-initialized-with-function) + (:method-lambdas-are-processed) + (:reinitialize-instance-calls-compute-discriminating-function) + (:reinitialize-instance-calls-finalize-inheritance) + (:remove-method-calls-compute-discriminating-function) + (:subclasses-of-method-combination-do-not-inherit-exported-slots)) + +:clisp2.40-2.41 +((:accessor-method-initialized-with-function) + (:add-method-calls-compute-discriminating-function) + (:compute-slots-requested-slot-order-honoured) + (:defmethod-calls-make-method-lambda) + (:forward-referenced-class-changed-by-change-class) + (:initialize-instance-calls-compute-discriminating-function) + (:make-method-lambda) + (:method-initialized-with-function) + (:method-lambdas-are-processed) + (:reinitialize-instance-calls-compute-discriminating-function) + (:remove-method-calls-compute-discriminating-function) + (:subclasses-of-method-combination-do-not-inherit-exported-slots)) + +:cmu19c-19d +((:accessor-method-initialized-with-function fixed) + (:accessor-method-initialized-with-lambda-list fixed) + (:accessor-method-initialized-with-slot-definition fixed) + (:accessor-method-initialized-with-specializers fixed) + (:anonymous-classes fixed) + (:class-default-initargs) + (:class-direct-default-initargs) + (:class-initialization-calls-reader-method-class fixed) + (:class-initialization-calls-writer-method-class fixed) + (:discriminating-functions-can-be-closures) + (:discriminating-functions-can-be-funcalled) + (:documentation-passed-to-effective-slot-definition-class) + (:effective-slot-definition-initialized-with-documentation) + (:method-initialized-with-function) + (:multiple-slot-options-passed-as-list-to-direct-slot-definition-class) ; fix with fix-slot-initargs + (:reinitialize-instance-calls-compute-discriminating-function fixed) + (:reinitialize-instance-calls-finalize-inheritance) + (:setf-class-name-calls-reinitialize-instance) + (:setf-generic-function-name-calls-reinitialize-instance) + (:slot-definition-documentation fixed) + (:standard-class-and-funcallable-standard-class-are-compatible) + (:subclasses-of-built-in-class-do-not-inherit-exported-slots) + (:subclasses-of-class-do-not-inherit-exported-slots) + (:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-eql-specializer-do-not-inherit-exported-slots) + (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots) + (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots) + (:subclasses-of-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-specializer-do-not-inherit-exported-slots) + (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-class-do-not-inherit-exported-slots) + (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) + (:subclasses-of-standard-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots)) + +:ecl0.9i +((:accessor-method-initialized-with-function fixed) + (:accessor-method-initialized-with-lambda-list fixed) + (:accessor-method-initialized-with-slot-definition fixed) + (:accessor-method-initialized-with-specializers fixed) + (:accessor-method-slot-definition fixed) + (:add-direct-method fixed) + (:add-method-calls-add-direct-method fixed) + (:add-method-calls-compute-discriminating-function) + (:add-method-calls-remove-method fixed) + (:add-method-updates-specializer-direct-generic-functions fixed) + (:add-method-updates-specializer-direct-methods fixed) + (:class-default-initargs) + (:class-direct-default-initargs) + (:class-initialization-calls-reader-method-class fixed) + (:class-initialization-calls-writer-method-class fixed) + (:class-reinitialization-calls-remove-direct-subclass fixed) + (:classes-are-always-their-own-valid-superclasses) + (:compute-applicable-methods-is-generic) + (:compute-applicable-methods-using-classes) + (:compute-effective-method-is-generic) + (:default-superclass-for-funcallable-standard-class-is-funcallable-standard-object) + (:default-reader-methods-are-standard-reader-methods fixed) + (:default-writer-methods-are-standard-writer-methods fixed) + (:defgeneric-calls-find-method-combination) + (:defmethod-calls-generic-function-method-class) + (:defmethod-calls-initialize-instance) + (:defmethod-calls-make-method-lambda) + (:dependent-protocol-for-classes) + (:dependent-protocol-for-generic-functions) + (:direct-slot-definition-initialized-with-type) + (:discriminating-functions-can-be-closures) + (:discriminating-functions-can-be-funcalled) + (:eql-specializer) + (:eql-specializer-object fixed) + (:eql-specializers-are-objects) + (:extract-lambda-list fixed) + (:extract-specializer-names fixed) + (:find-method-combination) + (:find-method-is-generic fixed) + (:funcallable-standard-class) + (:funcallable-standard-object) + (:function-invocation-calls-compute-applicable-methods) + (:function-invocation-calls-compute-applicable-methods-using-classes) + (:function-invocation-calls-compute-effective-method) + (:generic-function-declarations) + (:generic-function-method-class-is-generic) + (:generic-function-method-combination) + (:generic-functions-can-be-empty) + (:initform-passed-to-direct-slot-definition-class) + (:initform-passed-to-effective-slot-definition-class) + (:initialize-instance-calls-compute-discriminating-function) + (:intern-eql-specializer fixed) + (:make-method-lambda) + (:metaobject) + (:method-functions-take-processed-parameters) + (:method-initialized-with-documentation) + (:method-initialized-with-function) + (:method-initialized-with-lambda-list) + (:method-initialized-with-qualifiers) + (:method-initialized-with-specializers) + (:method-lambdas-are-processed) + (:multiple-slot-options-passed-as-list-to-direct-slot-definition-class) + (:reader-method-class fixed) + (:reinitialize-instance-calls-compute-discriminating-function) + (:remove-direct-method fixed) + (:remove-method-calls-compute-discriminating-function) + (:remove-method-calls-remove-direct-method fixed) + (:remove-method-is-generic fixed) + (:setf-class-name-calls-reinitialize-instance) + (:setf-generic-function-name) + (:setf-generic-function-name-calls-reinitialize-instance) + (:slot-definition-documentation) + (:slot-definition-initform) + (:slot-definition-initfunction) + (:slot-definition-type) + (:slot-reader-calls-slot-value-using-class fixed) + (:slot-writer-calls-slot-value-using-class fixed) + (:specializer) + (:specializer-direct-generic-functions fixed) + (:specializer-direct-methods fixed) + (:standard-accessor-method fixed) + (:standard-class-and-funcallable-standard-class-are-compatible) + (:standard-reader-method fixed) + (:standard-writer-method fixed) + (:subclasses-of-built-in-class-do-not-inherit-exported-slots) + (:subclasses-of-class-do-not-inherit-exported-slots) + (:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots) + (:subclasses-of-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-class-do-not-inherit-exported-slots) + (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) + (:subclasses-of-standard-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) + (:t-is-always-a-valid-superclass) + (:type-passed-to-direct-slot-definition-class) + (:validate-superclass) + (:writer-method-class fixed)) + +:lispworks4.4 +((:add-method-calls-add-direct-method fixed) + (:add-method-calls-compute-discriminating-function) + (:add-method-calls-remove-method fixed) + (:add-method-updates-specializer-direct-generic-functions fixed) + (:allocation-passed-to-effective-slot-definition-class) ; instead :flags-passed-to-effective-slot-definition-class + (:class-default-initargs) + (:class-direct-default-initargs) + (:class-initialized-with-direct-default-initargs) ; instead: conditionalization + (:class-reinitialization-calls-remove-direct-subclass fixed) + (:compute-applicable-methods-using-classes) + (:compute-default-initargs) + (:defgeneric-calls-find-method-combination) + (:direct-superclasses-by-default-empty) ; not fixed, but direct superclasses are automatically adjusted + (:effective-slot-definition-initialized-with-allocation) ; instead :effective-slot-definition-initialized-with-flags + (:eql-specializer) ; partially fixed + (:eql-specializer-object fixed) + (:eql-specializers-are-objects) + (:extensible-allocation) + (:finalize-inheritance-calls-compute-default-initargs) + (:find-method-combination fixed) ; partially + (:funcallable-standard-instance-access) + (:function-invocation-calls-compute-applicable-methods) + (:function-invocation-calls-compute-applicable-methods-using-classes) + (:generic-function-initialized-with-declarations) ; map from generic-function-initialized-with-declare + (:initialize-instance-calls-compute-discriminating-function) + (:intern-eql-specializer fixed) ; partially + (:make-method-lambda fixed) ; partially + (:method-functions-take-processed-parameters) + (:reinitialize-instance-calls-compute-discriminating-function) + (:remove-method-calls-compute-discriminating-function) + (:remove-method-calls-remove-direct-method fixed) + (:setf-class-name-calls-reinitialize-instance) + (:setf-generic-function-name-calls-reinitialize-instance) + (:setf-slot-value-using-class-specialized-on-slot-definition fixed) + (:slot-boundp-using-class-specialized-on-slot-definition fixed) + (:slot-makunbound-using-class-specialized-on-slot-definition fixed) + (:slot-reader-calls-slot-value-using-class fixed) + (:slot-value-using-class-specialized-on-slot-definition fixed) + (:slot-writer-calls-slot-value-using-class fixed) + (:specializer) + (:specializer-direct-generic-functions fixed) + (:standard-class-and-funcallable-standard-class-are-compatible) + (:standard-instance-access) + (:subclasses-of-built-in-class-do-not-inherit-exported-slots fixed) + (:subclasses-of-class-do-not-inherit-exported-slots fixed) + (:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots fixed) + (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots fixed) + (:subclasses-of-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-class-do-not-inherit-exported-slots fixed) + (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) + (:subclasses-of-standard-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots)) + +:lispworks5.0-5.0.2 +((:add-method-calls-compute-discriminating-function) + (:add-method-updates-specializer-direct-generic-functions fixed) + (:class-default-initargs) + (:class-direct-default-initargs) + (:compute-applicable-methods-using-classes) + (:compute-default-initargs) + (:defgeneric-calls-find-method-combination) + (:eql-specializer) ; partially fixed + (:eql-specializer-object fixed) + (:eql-specializers-are-objects) + (:extensible-allocation) + (:finalize-inheritance-calls-compute-default-initargs) + (:find-method-combination fixed) ; partially + (:funcallable-standard-instance-access) + (:function-invocation-calls-compute-applicable-methods) + (:function-invocation-calls-compute-applicable-methods-using-classes) + (:initialize-instance-calls-compute-discriminating-function) + (:intern-eql-specializer fixed) ; partially + (:make-method-lambda fixed) ; partially + (:method-functions-take-processed-parameters) + (:reinitialize-instance-calls-compute-discriminating-function) + (:remove-method-calls-compute-discriminating-function) + (:setf-slot-value-using-class-specialized-on-slot-definition fixed) + (:slot-boundp-using-class-specialized-on-slot-definition fixed) + (:slot-makunbound-using-class-specialized-on-slot-definition fixed) + (:slot-reader-calls-slot-value-using-class fixed) + (:slot-value-using-class-specialized-on-slot-definition fixed) + (:slot-writer-calls-slot-value-using-class fixed) + (:specializer) + (:specializer-direct-generic-functions fixed) + (:standard-class-and-funcallable-standard-class-are-compatible) + (:standard-instance-access) + (:subclasses-of-built-in-class-do-not-inherit-exported-slots fixed) + (:subclasses-of-class-do-not-inherit-exported-slots fixed) + (:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots fixed) + (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots fixed) + (:subclasses-of-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-class-do-not-inherit-exported-slots fixed) + (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) + (:subclasses-of-standard-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots)) + +:mcl +((:add-method-calls-compute-discriminating-function) + (:compute-applicable-methods-using-classes) + (:default-superclass-for-funcallable-standard-class-is-funcallable-standard-object) + (:defmethod-calls-generic-function-method-class) + (:defmethod-calls-make-method-lambda) + (:discriminating-functions-can-be-closures) + (:discriminating-functions-can-be-funcalled) + (:funcallable-standard-object) + (:function-invocation-calls-compute-applicable-methods) + (:function-invocation-calls-compute-applicable-methods-using-classes) + (:function-invocation-calls-compute-effective-method) + (:generic-function-declarations) + (:generic-function-initialized-with-declarations) + (:generic-functions-can-be-empty) + (:initialize-instance-calls-compute-discriminating-function) + (:make-method-lambda) + (:method-functions-take-processed-parameters) + (:method-lambdas-are-processed) + (:reinitialize-instance-calls-compute-discriminating-function) + (:reinitialize-lambda-list-reinitializes-argument-precedence-order) + (:remove-method-calls-compute-discriminating-function) + (:set-funcallable-instance-function) + (:setf-generic-function-name) + (:setf-generic-function-name-calls-reinitialize-instance) +; --- + (:compute-slots-requested-slot-order-honoured) + (:direct-slot-definition fixed) + (:direct-superclasses-by-default-empty) ; not fixed, but direct superclasses are automatically adjusted, not for funcallable-standard-class though + (:effective-slot-definition fixed) + (:eql-specializer fixed) + (:extensible-allocation) + (:multiple-slot-options-passed-as-list-to-direct-slot-definition-class) ; fix with fix-slot-initargs + (:reinitialize-instance-calls-finalize-inheritance) + (:setf-class-name-calls-reinitialize-instance) + (:slot-definition fixed) + (:standard-slot-definition fixed) + (:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) + (:subclasses-of-standard-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots)) + +:openmcl +((:add-method-calls-compute-discriminating-function) + (:compute-applicable-methods-using-classes) + (:default-superclass-for-funcallable-standard-class-is-funcallable-standard-object) + (:defmethod-calls-generic-function-method-class) + (:defmethod-calls-make-method-lambda) + (:discriminating-functions-can-be-closures) + (:discriminating-functions-can-be-funcalled) + (:funcallable-standard-object) + (:function-invocation-calls-compute-applicable-methods) + (:function-invocation-calls-compute-applicable-methods-using-classes) + (:function-invocation-calls-compute-effective-method) + (:generic-functions-can-be-empty) + (:initialize-instance-calls-compute-discriminating-function) + (:make-method-lambda) + (:method-functions-take-processed-parameters) + (:method-lambdas-are-processed) + (:reinitialize-instance-calls-compute-discriminating-function) + (:reinitialize-lambda-list-reinitializes-argument-precedence-order) + (:remove-method-calls-compute-discriminating-function) +; --- + (:compute-slots-requested-slot-order-honoured) + (:eql-specializer fixed) + (:reinitialize-instance-calls-finalize-inheritance) + (:slot-definition-documentation fixed) + (:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-generic-function-do-not-inherit-exported-slots) + (:subclasses-of-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slot) + (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) + (:subclasses-of-standard-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots)) + +:sbcl 0.9.16-1.0.10 +#| all features implemented |#

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/features.txt =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/features.txt 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/features.txt 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,225 @@ +Features that don't adhere to AMOP in various CLOS MOP implementations, and whether and how they are resolved in Closer to MOP. + +Allegro Common Lisp 7.0 + +- CLASS-DIRECT-DEFAULT-INITARGS and CLASS-DEFAULT-INITARGS don't return canonicalized default initargs as specified. Not fixed. +- COMPUTE-DEFAULT-INITARGS takes more parameters than specified. Not fixed. Conditionalize on #+allegro for your own methods instead. +- FUNCALLABLE-STANDARD-OBJECT is not used as the default superclass for classes with :metaclass FUNCALLABLE-STANDARD-CLASS. +- DEFGENERIC does not call FIND-METHOD-COMBINATION. Not fixed. +- DEFMETHOD doesn't call MAKE-METHOD-LAMBDA. Not fixed. +- The dependent protocol for generic functions doesn't work fully. Fixed. +- The function invocation protocol doesn't call COMPUTE-APPLICABLE-METHODS, COMPUTE-APPLICABLE-METHODS-USING-CLASSES and COMPUTE-EFFECTIVE-METHOD. Not fixed. +- The :ALLOCATION type cannot be extended. Fixed. +- MAKE-METHOD-LAMBDA is not provided. Not fixed. +- Method functions don't take parameters as specified in AMOP, but instead just the parameters that the generic function receives. Not fixed. +- The defmethod form does not accept multiple qualifiers. Not fixed. +- REINITIALIZE-INSTANCE doesn't determine a new discriminating function. Fixed. +- (SETF CLASS-NAME) and (SETF GENERIC-FUNCTION-NAME) do not use REINITIALIZE-INSTANCE for changing the names. Not fixed. +- SLOT-BOUNDP-USING-CLASS and SLOT-MAKUNBOUND-USING-CLASS are not specialized on slot definition metaobjects, but on symbols. Fixed. +- STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. Not fixed. +- VALIDATE-SUPERCLASS doesn't recognize T as a valid superclass. Not fixed. +- Subclasses of BUILT-IN-CLASS, FORWARD-REFERENCED-CLASS, FUNCALLABLE-STANDARD-CLASS, METHOD-COMBINATION, STANDARD-ACCESSOR-METHOD, STANDARD-CLASS, STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. + +Allegro Common Lisp 8.0 + +- CLASS-DIRECT-DEFAULT-INITARGS and CLASS-DEFAULT-INITARGS don't return canonicalized default initargs as specified. Not fixed. +- COMPUTE-DEFAULT-INITARGS takes more parameters than specified. Not fixed. Conditionalize on #+allegro for your own methods instead. +- FUNCALLABLE-STANDARD-OBJECT is not used as the default superclass for classes with :metaclass FUNCALLABLE-STANDARD-CLASS. +- DEFGENERIC does not call FIND-METHOD-COMBINATION. Not fixed. +- DEFMETHOD doesn't call MAKE-METHOD-LAMBDA. Not fixed. +- The dependent protocol for generic functions doesn't work fully. Fixed. +- The function invocation protocol doesn't call COMPUTE-APPLICABLE-METHODS, COMPUTE-APPLICABLE-METHODS-USING-CLASSES and COMPUTE-EFFECTIVE-METHOD. Not fixed. +- The :ALLOCATION type cannot be extended. Fixed. +- MAKE-METHOD-LAMBDA is not provided. Not fixed. +- Method functions don't take parameters as specified in AMOP, but instead just the parameters that the generic function receives. Not fixed. +- REINITIALIZE-INSTANCE doesn't determine a new discriminating function. Fixed. +- (SETF CLASS-NAME) and (SETF GENERIC-FUNCTION-NAME) do not use REINITIALIZE-INSTANCE for changing the names. Not fixed. +- SLOT-BOUNDP-USING-CLASS and SLOT-MAKUNBOUND-USING-CLASS are not specialized on slot definition metaobjects, but on symbols. Fixed. +- STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. Not fixed. +- VALIDATE-SUPERCLASS doesn't recognize T as a valid superclass. Not fixed. +- Subclasses of BUILT-IN-CLASS, FORWARD-REFERENCED-CLASS, FUNCALLABLE-STANDARD-CLASS, METHOD-COMBINATION, STANDARD-ACCESSOR-METHOD, STANDARD-CLASS, STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. + +Allegro Common Lisp 8.1 + +- CLASS-DIRECT-DEFAULT-INITARGS and CLASS-DEFAULT-INITARGS don't return canonicalized default initargs as specified. Not fixed. +- COMPUTE-DEFAULT-INITARGS takes more parameters than specified. Not fixed. Conditionalize on #+allegro for your own methods instead. +- FUNCALLABLE-STANDARD-OBJECT is not used as the default superclass for classes with :metaclass FUNCALLABLE-STANDARD-CLASS. +- DEFGENERIC does not call FIND-METHOD-COMBINATION. Not fixed. +- DEFMETHOD doesn't call MAKE-METHOD-LAMBDA. Not fixed. +- The dependent protocol for generic functions doesn't work fully. Fixed. +- The function invocation protocol doesn't call COMPUTE-APPLICABLE-METHODS, COMPUTE-APPLICABLE-METHODS-USING-CLASSES and COMPUTE-EFFECTIVE-METHOD. Not fixed. +- The :ALLOCATION type cannot be extended. Fixed. +- MAKE-METHOD-LAMBDA is not provided. Not fixed. +- Method functions don't take parameters as specified in AMOP, but instead just the parameters that the generic function receives. Not fixed. +- REINITIALIZE-INSTANCE doesn't determine a new discriminating function. Fixed. +- (SETF CLASS-NAME) and (SETF GENERIC-FUNCTION-NAME) do not use REINITIALIZE-INSTANCE for changing the names. Not fixed. +- SLOT-MAKUNBOUND-USING-CLASS is not specialized on slot definition metaobjects, but on symbols. Fixed. +- STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. Not fixed. +- VALIDATE-SUPERCLASS doesn't recognize T as a valid superclass. Not fixed. +- Subclasses of BUILT-IN-CLASS, FORWARD-REFERENCED-CLASS, FUNCALLABLE-STANDARD-CLASS, METHOD-COMBINATION, STANDARD-ACCESSOR-METHOD, STANDARD-CLASS, STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. + +CLisp 2.35 and 2.36 + +None of the incompatibilities in CLisp are fixed. + +- Methods are not initialized with :function. +- ADD-METHOD, REMOVE-METHOD, INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE do not determine a new discriminating function. This is postponed until function invocation instead, so shouldn't be a problem in practice. +- The slot order requested by a primary method for COMPUTE-SLOTS is not honoured by this MOP. +- DEFMETHOD does not call MAKE-METHOD-LAMBDA. +- The :ALLOCATION type cannot be extended. Not fixed. +- A FORWARD-REFERENCED-CLASS is not changed via CHANGE-CLASS (but is correctly reinitialized via REINITIALIZE-INSTANCE). +- MAKE-METHOD-LAMBDA is not provided. +- REINITIALIZE-INSTANCE of a class metaobject doesn't invoke FINALIZE-INHERITANCE again. Not fixed. +- Subclasses of METHOD-COMBINATION will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. + +CLisp 2.37 - 2.39 + +None of the incompatibilities in CLisp are fixed. + +- Methods are not initialized with :function. +- ADD-METHOD, REMOVE-METHOD, INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE do not determine a new discriminating function. This is postponed until function invocation instead, so shouldn't be a problem in practice. +- The slot order requested by a primary method for COMPUTE-SLOTS is not honoured by this MOP. +- DEFMETHOD does not call MAKE-METHOD-LAMBDA. +- A FORWARD-REFERENCED-CLASS is not changed via CHANGE-CLASS (but is correctly reinitialized via REINITIALIZE-INSTANCE). +- MAKE-METHOD-LAMBDA is not provided. +- REINITIALIZE-INSTANCE of a class metaobject doesn't invoke FINALIZE-INHERITANCE again. Not fixed. +- Subclasses of METHOD-COMBINATION will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. + +CLisp 2.40 and 2.41 + +None of the incompatibilities in CLisp are fixed. + +- Methods are not initialized with :function. +- ADD-METHOD, REMOVE-METHOD, INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE do not determine a new discriminating function. This is postponed until function invocation instead, so shouldn't be a problem in practice. +- The slot order requested by a primary method for COMPUTE-SLOTS is not honoured by this MOP. +- DEFMETHOD does not call MAKE-METHOD-LAMBDA. +- A FORWARD-REFERENCED-CLASS is not changed via CHANGE-CLASS (but is correctly reinitialized via REINITIALIZE-INSTANCE). +- MAKE-METHOD-LAMBDA is not provided. +- Subclasses of METHOD-COMBINATION will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. + +CMUCL 19c, 19d + +- CLASS-DIRECT-DEFAULT-INITARGS and CLASS-DEFAULT-INITARGS don't return canonicalized default initargs as specified. Not fixed. +- Accessor methods are not initialized with :function, :lambda-list, :slot-definition and :specializers. Fixed. +- Classes cannot be anonymous. Fixed. +- Class initialization doesn't call READER-METHOD-CLASS and WRITER-METHOD-CLASS for accessor methods. Fixed. +- The object returned by compute-discriminating-function cannot be a closure. Likewise, the second parameter to set-funcallable-instance-function cannot be a closure, but only a "pure" function/thunk. Not fixed. +- Effective slot definitions are not initialized with :documentation, and EFFECTIVE-SLOT-DEFINITION-CLASS also doesn't receive that initarg. Not fixed. +- Calling DOCUMENTATION on effective slot definition metaobjects don't return their documentation as specified in ANSI Common Lisp. Fixed. +- Methods are not initialized with :function. Not fixed. +- Multiple slot options are not passed as lists to DIRECT-SLOT-DEFINITION-CLASS. Not fixed, but use FIX-SLOT-INITARGS as a workaround. +- REINITIALIZE-INSTANCE doesn't determine a new discriminating function. Fixed. +- REINITIALIZE-INSTANCE of a class metaobject doesn't invoke FINALIZE-INHERITANCE again. Not fixed. +- (SETF CLASS-NAME) and (SETF GENERIC-FUNCTION-NAME) do not use REINITIALIZE-INSTANCE for changing the names. Fixed. +- STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. Not fixed. +- Subclasses of BUILT-IN-CLASS, CLASS, DIRECT-SLOT-DEFINITION, EFFECTIVE-SLOT-DEFINITION, EQL-SPECIALIZER, FORWARD-REFERENCED-CLASS, FUNCALLABLE-STANDARD-CLASS, SLOT-DEFINITION, SPECIALIZER, STANDARD-ACCESSOR-METHOD, STANDARD-CLASS, STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. + +LispWorks, 4.4.5, 4.4.6, Personal and Professional Editions + +- CLASS-DIRECT-DEFAULT-INITARGS and CLASS-DEFAULT-INITARGS don't return canonicalized default initargs as specified. Not fixed. +- ADD-METHOD doesn't call ADD-DIRECT-METHOD and REMOVE-METHOD. Fixed. +- ADD-METHOD, REMOVE-METHOD, INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE do not determine a new discriminating function. This is postponed until function invocation instead, so shouldn't be a problem in practice. +- Effective slot definitions are not initialized with :allocation, and EFFECTIVE-SLOT-DEFINITION-CLASS also doesn't receive that initarg. Not fixed. This information is encoded in the initarg :flags, but I don't have any detailed information about that parameter. +- Classes are not initialized with :direct-default-initargs, but with :default-initargs. Conditionalize on #+lispworks to fix this. +- Class reinitialization does not call REMOVE-DIRECT-SUBCLASS. Fixed. +- COMPUTE-APPLICABLE-METHODS-USING-CLASSES doesn't exist. Not fixed. +- COMPUTE-DEFAULT-INITARGS doesn't exist. Not fixed. +- DEFGENERIC does not call FIND-METHOD-COMBINATION. Not fixed. +- When classes are initialized, :direct-superclasses are by default not empty. Not fixed, but direct superclasses are automatically adjusted when you use the standard idiom for adding a new default superclass. +- EQL-SPECIALIZER, EQL-SPECIALIZER-OBJECT and INTERN-EQL-SPECIALIZER don't exist. In LispWorks, eql specializers are lists not objects. I have provided EQL-SPECIALIZER as a type (not as a class) and EQL-SPECIALIZER-OBJECT and INTERN-EQL-SPECIALIZER to work on lists, and a class EQL-SPECIALIZER* and corresponding EQL-SPECIALIZER-OBJECT* and INTERN-EQL-SPECILAIZER* to soften the incompatibilities. +- The :ALLOCATION type cannot be extended. Not fixed. +- FIND-METHOD-COMBINATION doesn't exist. Fixed, but fixed version doesn't work with method combination options. +- FUNCALLABLE-STANDARD-INSTANCE-ACCESS and STANDARD-INSTANCE-ACCESS don't exist. Not fixed. +- The function invocation protocol doesn't call COMPUTE-APPLICABLE-METHODS and COMPUTE-APPLICABLE-METHODS-USING-CLASSES. Not fixed. +- Generic functions are not initialized with :declarations, but with 'declare. Not fixed. Conditionalize on #+lispworks instead. +- MAKE-METHOD-LAMBDA expects other parameters than specified. Fixed. +- Method functions don't take parameters as specified in AMOP, but instead just the parameters that the generic function receives. Not fixed. +- REMOVE-METHOD doesn't call REMOVE-DIRECT-METHOD. Fixed. +- (SETF CLASS-NAME) and (SETF GENERIC-FUNCTION-NAME) do not use REINITIALIZE-INSTANCE for changing the names. Not fixed. +- The slot methods (SLOT-VALUE-USING-CLASS, etc.) are not specialized on effective slot definitions, but on slot names. Fixed. +- The generated accessor methods don't use the slot methods for accessing slots. Fixed. (Don't use :optimize-slot-access to deoptimize slot access, or otherwise the fixed slot access protocol doesn't work anymore!) +- SPECIALIZER doesn't exist. Not fixed. +- SPECIALIZER-DIRECT-GENERIC-FUNCTIONS doesn't exist. Fixed. +- STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. Not fixed. +- Subclasses of BUILT-IN-CLASS (fixed), CLASS (fixed), DIRECT-SLOT-DEFINITION, EFFECTIVE-SLOT-DEFINITION, FORWARD-REFERENCED-CLASS (fixed), FUNCALLABLE-STANDARD-CLASS (fixed), SLOT-DEFINITION, STANDARD-ACCESSOR-METHOD, STANDARD-CLASS (fixed), STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed, except where indicated otherwise. + + +LispWorks, 5.0 and 5.0.1, Personal Edition +LispWorks, 5.0 - 5.0.2, Professional Edition + +- CLASS-DIRECT-DEFAULT-INITARGS and CLASS-DEFAULT-INITARGS don't return canonicalized default initargs as specified. Not fixed. +- ADD-METHOD, REMOVE-METHOD, INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE do not determine a new discriminating function. This is postponed until function invocation instead, so shouldn't be a problem in practice. +- COMPUTE-APPLICABLE-METHODS-USING-CLASSES doesn't exist. Not fixed. +- COMPUTE-DEFAULT-INITARGS doesn't exist. Not fixed. +- DEFGENERIC does not call FIND-METHOD-COMBINATION. Not fixed. +- EQL-SPECIALIZER, EQL-SPECIALIZER-OBJECT and INTERN-EQL-SPECIALIZER don't exist. In LispWorks, eql specializers are lists not objects. I have provided EQL-SPECIALIZER as a type (not as a class) and EQL-SPECIALIZER-OBJECT and INTERN-EQL-SPECIALIZER to work on lists, and a class EQL-SPECIALIZER* and corresponding EQL-SPECIALIZER-OBJECT* and INTERN-EQL-SPECILAIZER* to soften the incompatibilities. +- The :ALLOCATION type cannot be extended. Not fixed. +- FIND-METHOD-COMBINATION doesn't exist. Fixed, but fixed version doesn't work with method combination options. +- FUNCALLABLE-STANDARD-INSTANCE-ACCESS and STANDARD-INSTANCE-ACCESS don't exist. Not fixed. +- The function invocation protocol doesn't call COMPUTE-APPLICABLE-METHODS and COMPUTE-APPLICABLE-METHODS-USING-CLASSES. Not fixed. +- MAKE-METHOD-LAMBDA expects other parameters than specified. Fixed. +- Method functions don't take parameters as specified in AMOP, but instead just the parameters that the generic function receives. Not fixed. +- The slot methods (SLOT-VALUE-USING-CLASS, etc.) are not specialized on effective slot definitions, but on slot names. Fixed. +- The generated accessor methods don't use the slot methods for accessing slots. Fixed. (Don't use :optimize-slot-access to deoptimize slot access, or otherwise the fixed slot access protocol doesn't work anymore!) +- SPECIALIZER doesn't exist. Not fixed. +- SPECIALIZER-DIRECT-GENERIC-FUNCTIONS doesn't exist. Fixed. +- STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. Not fixed. +- Subclasses of BUILT-IN-CLASS (fixed), CLASS (fixed), DIRECT-SLOT-DEFINITION, EFFECTIVE-SLOT-DEFINITION, FORWARD-REFERENCED-CLASS (fixed), FUNCALLABLE-STANDARD-CLASS (fixed), SLOT-DEFINITION, STANDARD-ACCESSOR-METHOD, STANDARD-CLASS (fixed), STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed, except where indicated otherwise. + + +MCL 5.1 + +In MCL, generic functions work completely differently than specified. The specific incompatibilities are not listed and are not fixed. + +- The slot order requested by a primary method for COMPUTE-SLOTS is not honoured by this MOP. Not fixed. +- DIRECT-SLOT-DEFINITION, EFFECTIVE-SLOT-DEFINITION, EQL-SPECIALIZER, SLOT-DEFINITION and STANDARD-SLOT-DEFINITION are not exported. Fixed. +- When classes are initialized, :direct-superclasses are by default not empty. Not fixed, but direct superclasses are automatically adjusted when you use the standard idiom for adding a new default superclass. +- The :ALLOCATION type cannot be extended. Not fixed. +- Multiple slot options are not passed as lists to DIRECT-SLOT-DEFINITION-CLASS. Not fixed, but use FIX-SLOT-INITARGS as a workaround. +- (SETF CLASS-NAME) doesn't use REINITIALIZE-INSTANCE for changing the names. Fixed. +- REINITIALIZE-INSTANCE of a class metaobject doesn't invoke FINALIZE-INHERITANCE again. Not fixed. +- Subclasses of DIRECT-SLOT-DEFINITION, EFFECTIVE-SLOT-DEFINITION, SLOT-DEFINITION, STANDARD-ACCESSOR-METHOD, STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. + +OpenMCL 1.0 + +In OpenMCL, generic functions work completely differently than specified. The specific incompatibilities are not listed and are not fixed. + +- The slot order requested by a primary method for COMPUTE-SLOTS is not honoured by this MOP. Not fixed. +- EQL-SPECIALIZER is not exported. Fixed. +- DOCUMENTATION doesn't return the documentation strings for slot definition metaobjects. Fixed. +- REINITIALIZE-INSTANCE of a class metaobject doesn't invoke FINALIZE-INHERITANCE again. Not fixed. +- Subclasses of DIRECT-SLOT-DEFINITION, EFFECTIVE-SLOT-DEFINITION, GENERIC-FUNCTION, SLOT-DEFINITION, STANDARD-ACCESSOR-METHOD, STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. + +SBCL 0.9.16 - 1.0.10 + +All features implemented. + + +Summary: + +- CLASS-DIRECT-DEFAULT-INITARGS and CLASS-DEFAULT-INITARGS exist, but don't work as expected in Allegro Common Lisp, CMUCL and LispWorks. +- If you specialize COMPUTE-DEFAULT-INITAGS, conditionalize for the extra parameters in Allegro Common Lisp. +- In Allegro Common Lisp, FUNCALLABLE-STANDARD-OBJECT is not used as the default superclass for classes with :metaclass FUNCALLABLE-STANDARD-CLASS. +- In CMUCL, the object returned by compute-discriminating-function cannot be a closure. Likewise, the second parameter to set-funcallable-instance-function cannot be a closure, but only a "pure" function/thunk. +- In CLisp, MCL and OpenMCL, the slot order requested by a primary method for COMPUTE-SLOTS is not honoured by the respective MOPs. +- Don't rely on FIND-METHOD-COMBINATION to do its job correctly, only when you don't provide method combination options. +- MAKE-METHOD-LAMBDA only works in CMUCL and SBCL as specified (but make sure that the respective generic function and method metaobject classes and make-method-lambda definitions are part of your compilation enviroment). MAKE-METHOD-LAMBDA also works in LispWorks, but the returned lambda expressions don't adhere to the AMOP specification (which may be good enough for your purposes). +- Specialize the methods for the dependent protocol on the class or generic function metaobject class. The example in AMOP doesn't do this but that is fragile code. +- Don't rely on methods being initialized with the specified initargs from inside the MOP. +- CLisp doesn't change a FORWARD-REFERENCED-CLASS via CHANGE-CLASS. Apart from that, FORWARD-REFERENCED-CLASS works reliably across all MOPs. +- Effective slot definitions and EFFECTIVE-SLOT-DEFINITION-CLASS don't receive :documentation in CMUCL, and no :allocation (!) in LispWorks before 5.0. +- If you specialize DIRECT-SLOT-DEFINITION-CLASS, use FIX-SLOT-INITARGS in portable code. +- If you want to use :ALLOCATION types other than :CLASS or :INSTANCE, you cannot use CLisp before 2.37, LispWorks or MCL. Only Allegro Common Lisp, CLisp from 2.37 on, CMUCL, OpenMCL and SBCL support this. +- In Allegro, CMUCL and LispWorks, STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. +- The function invocation protocol only works in CMUCL, SBCL and CLisp. +- If you need to see :direct-default-initargs when classes are initialized, conditionalize on #+lispworks to receive :default-initargs instead for LispWorks version before 5.0. +- COMPUTE-DEFAULT-INITARGS doesn't exist (and isn't called) in LispWorks. +- In LispWorks, eql specializers are lists. +- FUNCALLABLE-STANDARD-INSTANCE-ACCESS and STANDARD-INSTANCE-ACCESS doesn't exist / should not be used in LispWorks. +- In CLisp before version 2.40, and in CMUCL, MCL and OpenMCL, the reinitialization of a class metaobject does not lead to a call of FINALIZE-INHERITANCE, so methods defined on FINALIZE-INHERITANCE won't be called again in that case. +- If you need to see :declarations when generic functions are initialized, conditionalize on #+lispworks to receive 'declare instead for LispWorks versions before 5.0. (Actually, AMOP and ANSI Common Lisp diverge in this regard. AMOP specifies that :declarations is used whereas ANSI Common Lisp specifies that 'declare is used. Since most MOP implementations adhere to AMOP in this regard, I have also chosen that path.) +- In Allegro Common Lisp and LispWorks, method functions take the original parameters that a generic function has received. +- In LispWorks before 5.0, the class SPECIALIZER doesn't exist. +- If you need to rely on the generic function protocols, don't use MCL or OpenMCL (or be very careful - some minor things work there as specified). +- The declarations for a generic function cannot be inspected in MCL. +- All implementations define slots on various specified metaobject classes that are exported from some package and/or accessible in the package common-lisp-user. Only sbcl is safe from this, and clisp is relatively safe in that it does that only for the class METHOD-COMBINATION.

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/lispworks/closer-mop-packages.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/lispworks/closer-mop-packages.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/lispworks/closer-mop-packages.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,194 @@ +(in-package :cl-user) + +(defpackage #:closer-mop + (:use #:common-lisp #:lispworks) + (:nicknames #:c2mop) + + (:shadow + #:defclass #:defgeneric #:defmethod + #:ensure-generic-function + #:standard-class #:standard-generic-function) + (:export + #:defclass #:defgeneric #:defmethod + #:ensure-generic-function + #:standard-class #:standard-generic-function) + + (:import-from #:clos + + #:direct-slot-definition + #:effective-slot-definition + #-lispworks #:eql-specializer + #:forward-referenced-class + #-lispworks #:funcallable-standard-class + #+lispworks5.0 #:funcallable-standard-object + #:metaobject + #:slot-definition + #-lispworks #:specializer + #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + + #-lispworks4.3 #:accessor-method-slot-definition + #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #-lispworks #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #-lispworks #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #-lispworks #:eql-specializer-object + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #-lispworks #:find-method-combination + #-lispworks #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #-lispworks #:intern-eql-specializer + #-lispworks #:make-method-lambda + #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #-lispworks4.3 #:reader-method-class + #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #-lispworks #:specializer-direct-generic-functions + #:specializer-direct-methods + #-lispworks #:standard-instance-access + #:update-dependent + #:validate-superclass + #-lispworks4.3 #:writer-method-class) + + (:export + #:direct-slot-definition + #:effective-slot-definition + #:eql-specializer + #+lispworks #:eql-specializer* + #:forward-referenced-class + #:funcallable-standard-class + #:funcallable-standard-object + #:metaobject + #:slot-definition + #-lispworks #:specializer + #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + + #:ensure-finalized + #:ensure-method + #:fix-slot-initargs + #:required-args + + #-lispworks4.3 #:accessor-method-slot-definition + #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #-lispworks #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #-lispworks #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #:eql-specializer-object + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #:find-method-combination + #-lispworks #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #:intern-eql-specializer + #+lispworks #:intern-eql-specializer* + #:make-method-lambda + #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #-lispworks4.3 #:reader-method-class + #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #:specializer-direct-generic-functions + #:specializer-direct-methods + #-lispworks #:standard-instance-access + #:update-dependent + #:validate-superclass + #-lispworks4.3 #:writer-method-class))

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/lispworks/closer-mop.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/lispworks/closer-mop.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/lispworks/closer-mop.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,605 @@ +(in-package :closer-mop) + +;; Some utility functions. + +(defun required-args (lambda-list &optional (collector #'identity)) + (loop for arg in lambda-list + until (member arg lambda-list-keywords) + collect (funcall collector arg))) + +(defun ensure-finalized (class &optional (errorp t)) + (if (typep class 'class) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (when errorp (error "~S is not a class." class))) + class) + +;; We need a new standard-generic-function for various things. + +(cl:defclass standard-generic-function (cl:standard-generic-function) + ((initial-methods :initform '())) + (:metaclass clos:funcallable-standard-class)) + +;; The following ensures that the new standard-generic-function is used. + +(defun ensure-generic-function + (name &rest args + &key (generic-function-class 'standard-generic-function) + &allow-other-keys) + (declare (dynamic-extent args)) + (when (fboundp name) + (let ((function (fdefinition name))) + (unless (typep function 'generic-function) + (cerror "Discard existing definition and create generic function." + "~S is already fbound, but not as a generic function." name) + (fmakunbound name)))) + (if (fboundp name) + (let ((function (fdefinition name))) + (apply #'ensure-generic-function-using-class + function name args)) + (apply #'ensure-generic-function-using-class nil name + :generic-function-class generic-function-class + args))) + +;; We need a new standard-class for various things. + +(cl:defclass standard-class (cl:standard-class) + ()) + +;; validate-superclass for metaclass classes is a little bit +;; more tricky than for class metaobject classes because +;; we don't want to make all standard-classes compatible to +;; each other. + +;; Our validate-superclass may get passed a class-prototype +;; as its second argument, so don't expect its readers to +;; yield useful information. (In ANSI parlance, "the +;; consequences are undefined...") + +(cl:defmethod validate-superclass + ((class standard-class) + (superclass cl:standard-class)) + (or (when (eq (class-of class) (find-class 'standard-class)) + (or (eq (class-of superclass) (find-class 'cl:standard-class)) + (eq (class-of superclass) (find-class 'standard-class)))) + (call-next-method) + (when (eq (class-of superclass) (find-class 'cl:standard-class)) + (validate-superclass class (class-prototype (find-class 'standard-class)))))) + +;; The following macro ensures that the new standard-class is used +;; by default. It would have been useful to fix other deficiencies +;; in a complete redefinition of defclass, but there is no portable +;; way to ensure the necessary compile-time effects as specified +;; by ANSI Common Lisp. Therefore, we just expand to the original +;; cl:defclass. + +(defmacro defclass (name (&rest supers) &body options) + (if (member :metaclass options :key #'car) + `(cl:defclass ,name ,supers ,@options) + `(cl:defclass ,name ,supers ,@options + (:metaclass standard-class)))) + +;; We need a new funcallable-standard-class for various things. + +(cl:defclass funcallable-standard-class (clos:funcallable-standard-class) + ()) + +;; See the comment on validate-superclass for standard-class above. + +(cl:defmethod validate-superclass + ((class funcallable-standard-class) + (superclass clos:funcallable-standard-class)) + (or (when (eq (class-of class) (find-class 'funcallable-standard-class)) + (or (eq (class-of superclass) (find-class 'clos:funcallable-standard-class)) + (eq (class-of superclass) (find-class 'funcallable-standard-class)))) + (call-next-method) + (when (eq (class-of superclass) (find-class 'clos:funcallable-standard-class)) + (validate-superclass class (class-prototype (find-class 'funcallable-standard-class)))))) + +#+lispworks5.0 +(cl:defmethod validate-superclass + ((class funcallable-standard-class) + (superclass (eql (find-class 'funcallable-standard-object)))) + t) + +;; We also need a new funcallable-standard-object because the default one +;; is not an instance of clos:funcallable-standard-class. + +#-lispworks5.0 +(cl:defclass funcallable-standard-object (clos:funcallable-standard-object) + () + (:metaclass clos:funcallable-standard-class)) + +;; The following code ensures that possibly incorrect lists of direct +;; superclasses are corrected. + +#-lispworks5.0 +(defun modify-superclasses (direct-superclasses &optional (standardp t)) + (if (null direct-superclasses) + (list (if standardp + (find-class 'standard-object) + (find-class 'funcallable-standard-object))) + (let ((standard-object (if standardp + (find-class 'standard-object) + (find-class 'clos:funcallable-standard-object)))) + (if (eq (car (last direct-superclasses)) standard-object) + (if standardp + direct-superclasses + (append (butlast direct-superclasses) + (list (find-class 'funcallable-standard-object)))) + (remove standard-object direct-superclasses))))) + +;; During class re/initialization, we take care of the following things: +;; - Optimization of slot accessors is deactivated. +;; - Lists of direct superclasses are corrected. +;; - Removal of direct subclasses. + +(cl:defmethod initialize-instance :around + ((class standard-class) &rest initargs + #-lispworks5.0 &key + #-lispworks5.0 (direct-superclasses ())) + (declare (dynamic-extent initargs)) + (apply #'call-next-method class + #-lispworks5.0 :direct-superclasses + #-lispworks5.0 (modify-superclasses direct-superclasses) + :optimize-slot-access nil + initargs)) + +(cl:defmethod reinitialize-instance :around + ((class standard-class) &rest initargs + #-lispworks5.0 &key + #-lispworks5.0 (direct-superclasses () direct-superclasses-p)) + (declare (dynamic-extent initargs)) + #-lispworks5.0 + (progn + (when direct-superclasses-p + (setq direct-superclasses (modify-superclasses direct-superclasses)) + (loop for superclass in (copy-list (class-direct-superclasses class)) + unless (member superclass direct-superclasses) + do (remove-direct-subclass superclass class))) + (if direct-superclasses-p + (apply #'call-next-method class + :direct-superclasses direct-superclasses + :optimize-slot-access nil + initargs) + (apply #'call-next-method class + :optimize-slot-access nil + initargs))) + #+lispworks5.0 + (apply #'call-next-method class + :optimize-slot-access nil + initargs)) + +(cl:defmethod initialize-instance :around + ((class funcallable-standard-class) &rest initargs + #-lispworks5.0 &key + #-lispworks5.0 (direct-superclasses ())) + (declare (dynamic-extent initargs)) + (apply #'call-next-method class + #-lispworks5.0 :direct-superclasses + #-lispworks5.0 (modify-superclasses direct-superclasses nil) + :optimize-slot-access nil + initargs)) + +(cl:defmethod reinitialize-instance :around + ((class funcallable-standard-class) &rest initargs + #-lispworks5.0 &key + #-lispworks5.0 (direct-superclasses () direct-superclasses-p)) + (declare (dynamic-extent initargs)) + #-lispworks5.0 + (progn + (when direct-superclasses-p + (setq direct-superclasses (modify-superclasses direct-superclasses nil)) + (loop for superclass in (copy-list (class-direct-superclasses class)) + unless (member superclass direct-superclasses) + do (remove-direct-subclass superclass class))) + (if direct-superclasses-p + (apply #'call-next-method class + :direct-superclasses direct-superclasses + :optimize-slot-access nil + initargs) + (apply #'call-next-method class + :optimize-slot-access nil + initargs))) + #+lispworks5.0 + (apply #'call-next-method class + :optimize-slot-access nil + initargs)) + +;; The following is necessary for forward-referenced-classes. +;; Since we replace the original funcallable-standard-object with +;; a new one, we have to prevent LispWorks from trying to use +;; the original one when forward-ferenced-classes are resolved. + +#-lispworks5.0 +(cl:defmethod change-class :around + ((class forward-referenced-class) + (new-class funcallable-standard-class) + &rest initargs + &key (direct-superclasses ())) + (declare (dynamic-extent initargs)) + (apply #'call-next-method class new-class + :optimize-slot-access nil + :direct-superclasses (modify-superclasses direct-superclasses nil) + initargs)) + +;;; In LispWorks, the slot accessors (slot-value-using-class, etc.) are specialized +;;; on slot names instead of effective slot definitions. In order to fix this, +;;; we need to rewire the slot access protocol. + +(cl:defmethod slot-value-using-class + ((class standard-class) object (slot symbol)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (let ((slotd (find slot (class-slots class) + :test #'eq + :key #'slot-definition-name))) + (if slotd + (slot-value-using-class class object slotd) + (slot-missing class object slot 'slot-value)))) + +(cl:defmethod slot-value-using-class + ((class standard-class) object (slotd standard-effective-slot-definition)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (slot-value-using-class + (load-time-value (class-prototype (find-class 'cl:standard-class))) + object + (slot-definition-name slotd))) + +(cl:defmethod (setf slot-value-using-class) + (new-value (class standard-class) object (slot symbol)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (let ((slotd (find slot (class-slots class) + :test #'eq + :key #'slot-definition-name))) + (if slotd + (setf (slot-value-using-class class object slotd) + new-value) + (slot-missing class object slot 'setf new-value)))) + +(cl:defmethod (setf slot-value-using-class) + (new-value (class standard-class) object (slotd standard-effective-slot-definition)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (setf (slot-value-using-class + (load-time-value (class-prototype (find-class 'cl:standard-class))) + object + (slot-definition-name slotd)) + new-value)) + +(cl:defmethod slot-boundp-using-class + ((class standard-class) object (slot symbol)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (let ((slotd (find slot (class-slots class) + :test #'eq + :key #'slot-definition-name))) + (if slotd + (slot-boundp-using-class class object slotd) + (slot-missing class object slot 'slot-boundp)))) + +(cl:defmethod slot-boundp-using-class + ((class standard-class) object (slotd standard-effective-slot-definition)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (slot-boundp-using-class + (load-time-value (class-prototype (find-class 'cl:standard-class))) + object + (slot-definition-name slotd))) + +(cl:defmethod slot-makunbound-using-class + ((class standard-class) object (slot symbol)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (let ((slotd (find slot (class-slots class) + :test #'eq + :key #'slot-definition-name))) + (if slotd + (slot-makunbound-using-class class object slotd) + (slot-missing class object slot 'slot-makunbound)))) + +(cl:defmethod slot-makunbound-using-class + ((class standard-class) object (slotd standard-effective-slot-definition)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (slot-makunbound-using-class + (load-time-value (class-prototype (find-class 'cl:standard-class))) + object + (slot-definition-name slotd))) + +;; In LispWorks, eql specializers are lists. We cannot change this +;; but we can soften some of the incompatibilities. + +(deftype eql-specializer () + '(or eql-specializer* + (satisfies clos:eql-specializer-p))) + +(cl:defgeneric eql-specializer-object (eql-specializer) + (:method ((cons cons)) + (if (clos:eql-specializer-p cons) + (cadr cons) + (error "~S is not an eql-specializer." cons)))) + +(defun intern-eql-specializer (object) + `(eql ,object)) + +(cl:defclass eql-specializer* (metaobject) + ((obj :reader eql-specializer-object + :initarg eso + :initform (error "Use intern-eql-specializer to create eql-specializers.")) + (direct-methods :reader specializer-direct-methods + :accessor es-direct-methods + :initform ()))) + +(defvar *eql-specializers* (make-hash-table)) + +(defun intern-eql-specializer* (object) + (or (gethash object *eql-specializers*) + (setf (gethash object *eql-specializers*) + (make-instance 'eql-specializer* 'eso object)))) + +(cl:defmethod add-direct-method ((specializer eql-specializer*) (method method)) + (pushnew method (es-direct-methods specializer))) + +(cl:defmethod remove-direct-method ((specializer eql-specializer*) (method method)) + (removef (es-direct-methods specializer) method)) + +(cl:defgeneric specializer-direct-generic-functions (specializer) + (:method ((class class)) + (remove-duplicates + (mapcar #'method-generic-function + (specializer-direct-methods class)))) + (:method ((eql-specializer eql-specializer*)) + (remove-duplicates + (mapcar #'method-generic-function + (specializer-direct-methods eql-specializer)))) + (:method ((cons cons)) + (specializer-direct-generic-functions + (intern-eql-specializer* + (eql-specializer-object cons))))) + +;; The following method ensures that remove-method is called. + +#-lispworks5.0 +(cl:defmethod add-method :before ((gf standard-generic-function) (method method)) + (when-let (old-method (find-method gf (method-qualifiers method) + (method-specializers method) nil)) + (remove-method gf old-method))) + +;; The following two methods ensure that add/remove-direct-method is called, +;; and that the dependent protocol for generic function works. + +(cl:defmethod add-method :after ((gf standard-generic-function) (method method)) + (loop for specializer in (method-specializers method) + if (consp specializer) + do (add-direct-method + (intern-eql-specializer* + (eql-specializer-object specializer)) + method) + #-lispworks5.0 else + #-lispworks5.0 do + #-lispworks5.0 (add-direct-method specializer method)) + #+lispworks4.3 + (map-dependents + gf (lambda (dep) (update-dependent gf dep 'add-method method)))) + +(cl:defmethod remove-method :after ((gf standard-generic-function) (method method)) + (loop for specializer in (method-specializers method) + if (consp specializer) + do (remove-direct-method + (intern-eql-specializer* + (eql-specializer-object specializer)) + method) + #-lispworks5.0 else + #-lispworks5.0 do + #-lispworks5.0 (remove-direct-method specializer method)) + #+lispworks4.3 + (map-dependents + gf (lambda (dep) (update-dependent gf dep 'remove-method method)))) + +(cl:defgeneric find-method-combination (gf combi combi-options) + (:method ((gf generic-function) (combi symbol) combi-options) + (when combi-options + (error "This implementation of find-method-combination cannot handle method combination options.")) + (clos::find-a-method-combination-type combi))) + +;; In LispWorks, make-method-lambda expects different arguments than those +;; specified in AMOP. We just bridge this. The method lambda returned +;; still doesn't conform to AMOP, but may be good enough. + +(cl:defgeneric make-method-lambda (gf method lambda-expression env) + (:method ((gf cl:standard-generic-function) + (method standard-method) + lambda-expression env) + (declare (ignorable env)) + (destructuring-bind + (lambda (&rest args) &body body) + lambda-expression + (declare (ignore lambda)) + (loop with documentation = :unbound + for (car . cdr) = body then cdr + while (or (stringp car) + (and (consp car) (eq (car car) 'declare))) + if (stringp car) + do (setf documentation + (if (eq documentation :unbound) car + (error "Too many documentation strings in lambda expression ~S." + lambda-expression))) + else append (loop for declaration in (cdr car) + if (eq (car declaration) 'ignore) + collect `(ignorable ,@(cdr declaration)) + and collect `(dynamic-extent ,@(cdr declaration)) + else collect declaration) into declarations + finally (multiple-value-bind + (method-lambda method-args) + (clos:make-method-lambda + gf method args declarations + `(progn ,car ,@cdr) env) + (if (eq documentation :unbound) + (return (values method-lambda method-args)) + (return (values + `(lambda ,(cadr method-lambda) + ,documentation + ,@(cddr method-lambda)) + method-args)))))))) + +(defun ensure-method (gf lambda-expression + &key (method-class (generic-function-method-class gf)) + (qualifiers ()) + (lambda-list (cadr lambda-expression)) + (specializers (required-args lambda-list (constantly (find-class 't))))) + (multiple-value-bind + (method-lambda method-args) + (make-method-lambda + gf (class-prototype method-class) + lambda-expression ()) + (let ((method (apply #'make-instance + method-class + :qualifiers qualifiers + :lambda-list lambda-list + :specializers specializers + :function (compile nil method-lambda) + method-args))) + (add-method gf method) + method))) + +;; helper function for creating a generic function lambda list +;; from a method lambda list. +(defun create-gf-lambda-list (method-lambda-list) + (loop with stop-keywords = '#.(remove '&optional lambda-list-keywords) + for arg in method-lambda-list + until (member arg stop-keywords) + collect arg into gf-lambda-list + finally (return (let (rest) + (cond ((member '&key method-lambda-list) + (nconc gf-lambda-list '(&key))) + ((setq rest (member '&rest method-lambda-list)) + (nconc gf-lambda-list (subseq rest 0 2))) + (t gf-lambda-list)))))) + +;; The defmethod macro is needed in order to ensure that make-method-lambda +;; is called. (Unfortunately, this doesn't work in the other CL implementations.) + +(defmacro defmethod (&whole form name &body body &environment env) + (loop for tail = body then (cdr tail) + until (listp (car tail)) + collect (car tail) into qualifiers + finally + (destructuring-bind + ((&rest specialized-args) &body body) tail + (loop with documentation = :unbound + for (car . cdr) = body then cdr + while (or (stringp car) + (and (consp car) (eq (car car) 'declare))) + if (stringp car) + do (setq documentation + (if (eq documentation :unbound) car + (error "Too many documentation strings for defmethod form ~S." form))) + else append (cdr car) into declarations + finally + (let* ((lambda-list (extract-lambda-list specialized-args)) + (gf-lambda-list (create-gf-lambda-list lambda-list)) + (gf (if (fboundp name) + (ensure-generic-function name) + (ensure-generic-function name :lambda-list gf-lambda-list))) + (method-class (generic-function-method-class gf)) + (lambda-expression `(lambda ,lambda-list + (declare ,@declarations) + (block ,name ,car ,@cdr)))) + (if (equal (compute-applicable-methods + #'make-method-lambda + (list gf (class-prototype method-class) + lambda-expression env)) + (list (find-method + #'make-method-lambda '() + (list (find-class 'cl:standard-generic-function) + (find-class 'standard-method) + (find-class 't) + (find-class 't)) + nil))) + (return-from defmethod `(cl:defmethod ,@(rest form))) + (multiple-value-bind + (method-lambda method-args) + (make-method-lambda + gf (class-prototype method-class) + lambda-expression env) + (with-unique-names (gf method) + (return-from defmethod + `(let ((,gf (if (fboundp ',name) + (ensure-generic-function ',name) + (ensure-generic-function + ',name :lambda-list ',gf-lambda-list))) + (,method + (make-instance + ',method-class + :qualifiers ',qualifiers + :specializers + (list + ,@(mapcar + (lambda (specializer-name) + (typecase specializer-name + (symbol `(find-class ',specializer-name)) + (cons (cond + ((> (length specializer-name) 2) + (error "Invalid specializer ~S in defmethod form ~S." + specializer-name form)) + ((eq (car specializer-name) 'eql) + `(intern-eql-specializer ,(cadr specializer-name))) + (t (error "Invalid specializer ~S in defmethod form ~S." + specializer-name form)))) + (t (error "Invalid specializer ~S in defmethod form ~S." + specializer-name form)))) + (extract-specializer-names specialized-args))) + :lambda-list ',lambda-list + :function (function ,method-lambda) + ,@(unless (eq documentation :unbound) + (list :documentation documentation)) + ,@method-args))) + (add-method ,gf ,method) + ,method)))))))))) + +;; The following macro ensures that the new standard-generic-function +;; is used by default. It also ensures that make-method-lambda is called +;; for the default methods, by expanding into defmethod forms. + +(defmacro defgeneric (&whole form name (&rest args) &body options) + (unless (every #'consp options) + (error "Illegal generic functions options in defgeneric form ~S." form)) + `(progn + (let ((generic-function (ignore-errors (fdefinition ',name)))) + (when (and generic-function (typep generic-function 'standard-generic-function)) + (loop for method in (slot-value generic-function 'initial-methods) + do (remove-method generic-function method)))) + (cl:defgeneric ,name ,args + ,@(remove :method options :key #'car :test #'eq) + ,@(unless (member :generic-function-class options :key #'car :test #'eq) + '((:generic-function-class standard-generic-function)))) + (let ((generic-function (fdefinition ',name))) + (setf (slot-value generic-function 'initial-methods) + (list ,@(loop for method-spec in (remove :method options :key #'car :test-not #'eq) + collect `(defmethod ,name ,@(cdr method-spec))))) + generic-function))) + +;; The following can be used in direct-slot-definition-class to get the correct initargs +;; for a slot. Use it like this: +;; +;; (defmethod direct-slot-definition-class +;; ((class my-standard-class) &rest initargs) +;; (declare (dynamic-extent initargs)) +;; (destructuring-bind +;; (&key key-of-interest &allow-other-keys) +;; (fix-slot-initargs initargs) +;; ...)) + +(defvar *standard-slot-keys* + '(:name :documentation + :initargs :initform :initfunction + :readers :writers)) + +(defun fix-slot-initargs (initargs) + initargs) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew :closer-mop *features*))

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/mcl/closer-mop-packages.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/mcl/closer-mop-packages.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/mcl/closer-mop-packages.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,190 @@ +(in-package :cl-user) + +(defpackage #:closer-mop + (:use #:common-lisp #:lispworks) + (:nicknames #:c2mop) + + #-openmcl + (:shadow #:defclass #:standard-class #:typep #:subtypep) + #-openmcl + (:export #:defclass #:standard-class #:typep #:subtypep) + + (:import-from #:ccl + + #:direct-slot-definition + #:effective-slot-definition + #:eql-specializer + #:forward-referenced-class + #:funcallable-standard-class + #-(or mcl openmcl) #:funcallable-standard-object + #:metaobject + #:slot-definition + #:specializer + #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + + #:accessor-method-slot-definition + #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #-(or mcl openmcl) #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #:eql-specializer-object + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #:find-method-combination + #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #:intern-eql-specializer + #-(or mcl openmcl) #:make-method-lambda + #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #:reader-method-class + #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #+openmcl #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #:specializer-direct-generic-functions + #:specializer-direct-methods + #:standard-instance-access + #:update-dependent + #:validate-superclass + #:writer-method-class) + + (:export + #:direct-slot-definition + #:effective-slot-definition + #:eql-specializer + #:forward-referenced-class + #:funcallable-standard-class + #-(or mcl openmcl) #:funcallable-standard-object + #:metaobject + #:slot-definition + #:specializer + #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + + #:ensure-finalized + #:ensure-method + #:fix-slot-initargs + #:required-args + + #:accessor-method-slot-definition + #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #-(or mcl openmcl) #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #:eql-specializer-object + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #:find-method-combination + #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #:intern-eql-specializer + #-(or mcl openmcl) #:make-method-lambda + #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #:reader-method-class + #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #+openmcl #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #:specializer-direct-generic-functions + #:specializer-direct-methods + #:standard-instance-access + #-openmcl #:subtypep + #-openmcl #:typep + #:update-dependent + #:validate-superclass + #:writer-method-class))

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/mcl/closer-mop.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/mcl/closer-mop.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/mcl/closer-mop.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,177 @@ +(in-package :closer-mop) + +;; Some utility functions. + +(defun required-args (lambda-list &optional (collector #'identity)) + (loop for arg in lambda-list + until (member arg lambda-list-keywords) + collect (funcall collector arg))) + +(defun ensure-finalized (class &optional (errorp t)) + (if (typep class 'class) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (when errorp (error "~S is not a class." class))) + class) + +#-openmcl +(progn + ;; We need a new standard-class for various things. + + (cl:defclass standard-class (cl:standard-class) + ()) + + ;; validate-superclass for metaclass classes is a little bit + ;; more tricky than for class metaobject classes because + ;; we don't want to make all standard-classes compatible to + ;; each other. + + ;; Our validate-superclass may get passed a class-prototype + ;; as its second argument, so don't expect its readers to + ;; yield useful information. (In ANSI parlance, "the + ;; consequences are undefined...") + + (cl:defmethod validate-superclass + ((class standard-class) + (superclass cl:standard-class)) + (or (when (eq (class-of class) (find-class 'standard-class)) + (or (eq (class-of superclass) (find-class 'cl:standard-class)) + (eq (class-of superclass) (find-class 'standard-class)))) + (call-next-method) + (when (eq (class-of superclass) (find-class 'cl:standard-class)) + (validate-superclass class (class-prototype (find-class 'standard-class)))))) + + ;; The following macro ensures that the new standard-class is used + ;; by default. It would have been useful to fix other deficiencies + ;; in a complete redefinition of defclass, but there is no portable + ;; way to ensure the necessary compile-time effects as specified + ;; by ANSI Common Lisp. Therefore, we just expand to the original + ;; cl:defclass. + + (defmacro defclass (name (&rest supers) &body options) + (if (member :metaclass options :key #'car) + `(cl:defclass ,name ,supers ,@options) + `(cl:defclass ,name ,supers ,@options + (:metaclass standard-class)))) + + ;; In MCL, the list of direct superclasses passed by the + ;; defclass macro is not empty, as required by AMOP, but + ;; instead passes the class metaobject for standard-object + ;; or funcallable-standard-object respectively. This makes + ;; replacing the default superclass for a new metaclass a bit + ;; more complicated. In order to avoid the tricky bits in user + ;; code, the new standard-class adjusts possible incorrect + ;; direct superclasses by adding or removing the metaobject + ;; for standard-object as needed before passing them to + ;; the original standard-class. In user code, just use the + ;; idiom suggested by AMOP to APPEND your new default superclass + ;; to the list of direct superclasses. + + (defun modify-superclasses (direct-superclasses) + (if (null direct-superclasses) + (list (find-class 'standard-object)) + (let ((standard-object (find-class 'standard-object))) + (if (eq (car (last direct-superclasses)) standard-object) + direct-superclasses + (remove standard-object direct-superclasses))))) + + (cl:defmethod initialize-instance :around + ((class standard-class) &rest initargs + &key (name (gensym)) (direct-superclasses ())) + (declare (dynamic-extent initargs)) + (apply #'call-next-method class + :name name + :direct-superclasses (modify-superclasses direct-superclasses) + initargs)) + + (cl:defmethod reinitialize-instance :around + ((class standard-class) &rest initargs + &key (direct-superclasses () direct-superclasses-p)) + (declare (dynamic-extent initargs)) + (if direct-superclasses-p + (apply #'call-next-method class + :direct-superclasses (modify-superclasses direct-superclasses) + initargs) + (call-next-method))) + + (defgeneric typep (object type) + (:method (object type) + (cl:typep object type)) + (:method (object (type class)) + (member (class-of object) + (class-precedence-list type)))) + + (defgeneric subtypep (type1 type2) + (:method (type1 type2) + (cl:subtypep type1 type2)) + (:method ((type1 class) (type2 symbol)) + (let ((class2 (find-class type2 nil))) + (if class2 + (member class2 (class-precedence-list type1)) + (cl:subtypep type1 type2)))) + (:method ((type1 symbol) (type2 class)) + (let ((class1 (find-class type1 nil))) + (if class1 + (member type2 (class-precedence-list class1)) + (cl:subtypep type1 type2)))) + (:method ((type1 class) (type2 class)) + (member type2 (class-precedence-list type1))))) + +(defun ensure-method (gf lambda-expression + &key (qualifiers ()) + (lambda-list (cadr lambda-expression)) + (specializers (required-args lambda-list (constantly (find-class 't))))) + (eval `(defmethod ,(generic-function-name gf) ,@qualifiers + ,(loop for specializer in specializers + for (arg . rest) on lambda-list + collect `(,arg ,specializer) into args + finally (return (nconc args rest))) + ,@(cddr lambda-expression)))) + +;; The following ensures that slot definitions have a documentation in OpenMCL. + +#+openmcl +(defmethod initialize-instance :after ((slot slot-definition) &key documentation) + (setf (documentation slot 't) documentation)) + +;; The following can be used in direct-slot-definition-class to get the correct initargs +;; for a slot. Use it like this: +;; +;; (defmethod direct-slot-definition-class +;; ((class my-standard-class) &rest initargs) +;; (declare (dynamic-extent initargs)) +;; (destructuring-bind +;; (&key key-of-interest &allow-other-keys) +;; (fix-slot-initargs initargs) +;; ...)) + +(defvar *standard-slot-keys* + '(:name :documentation + :initargs :initform :initfunction + :readers :writers)) + +(defun fix-slot-initargs (initargs) + #+openmcl initargs + #-openmcl + (let* ((counts (loop with counts + for (key nil) on initargs by #'cddr + do (incf (getf counts key 0)) + finally (return counts))) + (keys-to-fix (loop for (key value) on counts by #'cddr + if (> value 1) collect key))) + (if keys-to-fix + (let ((multiple-standard-keys + (intersection keys-to-fix *standard-slot-keys*))) + (if multiple-standard-keys + (error "Too many occurences of ~S in slot initargs ~S." + multiple-standard-keys initargs) + (loop with fixed-keys + for (key value) on initargs by #'cddr + if (member key keys-to-fix) + do (nconcf (getf fixed-keys key) (list value)) + else nconc (list key value) into fixed-initargs + finally (return (nconc fixed-initargs fixed-keys))))) + initargs))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew :closer-mop *features*))

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/pcl/closer-mop-packages.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/pcl/closer-mop-packages.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/pcl/closer-mop-packages.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,190 @@ +(in-package :cl-user) + +(defpackage #:closer-mop + (:use #:common-lisp #:lispworks) + (:nicknames #:c2mop) + + #-sbcl (:shadow #:typep #:subtypep) + #-sbcl (:export #:typep #:subtypep) + + (:import-from + #+cmu #:clos-mop + #+sbcl #:sb-mop + + #:direct-slot-definition + #:effective-slot-definition + #:eql-specializer + #:forward-referenced-class + #:funcallable-standard-class + #:funcallable-standard-object + #:metaobject + #:slot-definition + #:specializer + #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + + #:accessor-method-slot-definition + #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #:eql-specializer-object + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #:find-method-combination + #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #:intern-eql-specializer + #:make-method-lambda + #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #:reader-method-class + #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #:specializer-direct-generic-functions + #:specializer-direct-methods + #:standard-instance-access + #:update-dependent + #:validate-superclass + #:writer-method-class) + + (:export + #:direct-slot-definition + #:effective-slot-definition + #:eql-specializer + #:forward-referenced-class + #:funcallable-standard-class + #:funcallable-standard-object + #:metaobject + #:slot-definition + #:specializer + #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + + #:ensure-finalized + #:ensure-method + #:fix-slot-initargs + #:required-args + + #:accessor-method-slot-definition + #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #:eql-specializer-object + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #:find-method-combination + #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #:intern-eql-specializer + #:make-method-lambda + #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #:reader-method-class + #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #:specializer-direct-generic-functions + #:specializer-direct-methods + #:standard-instance-access + #:subtypep + #:typep + #:update-dependent + #:validate-superclass + #:writer-method-class))

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/pcl/closer-mop.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/pcl/closer-mop.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/pcl/closer-mop.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,284 @@ +(in-package :closer-mop) + +;; Some utility functions. + +(defun required-args (lambda-list &optional (collector #'identity)) + (loop for arg in lambda-list + until (member arg lambda-list-keywords) + collect (funcall collector arg))) + +(defun ensure-finalized (class &optional (errorp t)) + (if (typep class 'class) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (when errorp (error "~S is not a class." class))) + class) + +;; The following is commented out. SBCL now supports compatible standard-class and +;; funcallable-standard-class metaclasses, but this requires that we don't mess with +;; the class hierarchy anymore. So we will try the trick we have already used +;; for generic functions: We just add methods for the existing metaclasses. +;; This is not AMOP-compliant, but if it works it works. + +#| +;; We need a new standard-class for various things. + +(cl:defclass standard-class (cl:standard-class) + ()) + +;; validate-superclass for metaclass classes is a little bit +;; more tricky than for class metaobject classes because +;; we don't want to make all standard-classes compatible to +;; each other. + +;; Our validate-superclass may get passed a class-prototype +;; as its second argument, so don't expect its readers to +;; yield useful information. (In ANSI parlance, "the +;; consequences are undefined...") + +(cl:defmethod validate-superclass + ((class standard-class) + (superclass cl:standard-class)) + (or (when (eq (class-of class) (find-class 'standard-class)) + (or (eq (class-of superclass) (find-class 'cl:standard-class)) + (eq (class-of superclass) (find-class 'standard-class)))) + (call-next-method) + (when (eq (class-of superclass) (find-class 'cl:standard-class)) + (validate-superclass class (class-prototype (find-class 'standard-class)))))) + +#+sbcl +(cl:defmethod validate-superclass + ((class funcallable-standard-class) + (superclass standard-class)) + (and (eq (class-of class) (find-class 'funcallable-standard-class)) + (eq (class-of superclass) (find-class 'standard-class)))) + +;; The following macro ensures that the new standard-class is used +;; by default. It would have been useful to fix other deficiencies +;; in a complete redefinition of defclass, but there is no portable +;; way to ensure the necessary compile-time effects as specified +;; by ANSI Common Lisp. Therefore, we just expand to the original +;; cl:defclass. + +(defmacro defclass (name (&rest supers) &body options) + (if (member :metaclass options :key #'car) + `(cl:defclass ,name ,supers ,@options) + `(cl:defclass ,name ,supers ,@options + (:metaclass standard-class)))) +|# + +;; In CMUCL, reader-method-class and writer-method-class are +;; not used during class initialization. The following definitions +;; correct this. + +#-sbcl +(defun modify-accessors (class) + (loop with reader-specializers = (list class) + with writer-specializers = (list (find-class 't) class) + for slotd in (class-direct-slots class) do + (loop for reader in (slot-definition-readers slotd) + for reader-function = (fdefinition reader) + for reader-method = (find-method reader-function () reader-specializers) + for initargs = (list :qualifiers () + :lambda-list '(object) + :specializers reader-specializers + :function (method-function reader-method) + :slot-definition slotd) + for method-class = (apply #'reader-method-class class slotd initargs) + unless (eq method-class (class-of reader-method)) + do (add-method reader-function (apply #'make-instance method-class initargs))) + (loop for writer in (slot-definition-writers slotd) + for writer-function = (fdefinition writer) + for writer-method = (find-method writer-function () writer-specializers) + for initargs = (list :qualifiers () + :lambda-list '(new-value object) + :specializers writer-specializers + :function (method-function writer-method) + :slot-definition slotd) + for method-class = (apply #'writer-method-class class slotd initargs) + unless (eq method-class (class-of writer-method)) + do (add-method writer-function (apply #'make-instance method-class initargs))))) + +;; The following methods additionally create a gensym for the class name +;; unless a name is explicitly provided. AMOP requires classes to be +;; potentially anonymous. + +#-sbcl +(cl:defmethod initialize-instance :around + ((class standard-class) &rest initargs + &key (name (gensym))) + (declare (dynamic-extent initargs)) + (prog1 (apply #'call-next-method class :name name initargs) + (modify-accessors class))) + +#-sbcl +(cl:defmethod initialize-instance :around + ((class funcallable-standard-class) &rest initargs + &key (name (gensym))) + (declare (dynamic-extent initargs)) + (prog1 (apply #'call-next-method class :name name initargs) + (modify-accessors class))) + +#-sbcl +(cl:defmethod reinitialize-instance :after + ((class standard-class) &key) + (modify-accessors class)) + +#-sbcl +(cl:defmethod reinitialize-instance :after + ((class funcallable-standard-class) &key) + (modify-accessors class)) + +;;; The following three methods ensure that the dependent protocol +;;; for generic function works. + +;; The following method additionally ensures that +;; compute-discriminating-function is triggered. + +; Note that for CMUCL, these methods violate the AMOP specification +; by specializing on the original standard-generic-function metaclass. However, +; this is necassary because in CMUCL, only one subclass of +; standard-generic-function can be created, and taking away that option from user +; code doesn't make a lot of sense in our context. + +#-sbcl +(cl:defmethod reinitialize-instance :after + ((gf standard-generic-function) &rest initargs) + (declare (dynamic-extent initargs)) + (set-funcallable-instance-function + gf (compute-discriminating-function gf)) + #-cmu + (map-dependents + gf (lambda (dep) (apply #'update-dependent gf dep initargs)))) + +#-(or cmu sbcl) +(cl:defmethod add-method :after + ((gf standard-generic-function) method) + (map-dependents + gf (lambda (dep) (update-dependent gf dep 'add-method method)))) + +#-(or cmu sbcl) +(cl:defmethod remove-method :after + ((gf standard-generic-function) method) + (map-dependents + gf (lambda (dep) (update-dependent gf dep 'remove-method method)))) + +#+sbcl +(defun ensure-method (gf lambda-expression + &key (method-class (generic-function-method-class gf)) + (qualifiers ()) + (lambda-list (cadr lambda-expression)) + (specializers (required-args lambda-list (constantly (find-class 't))))) + (multiple-value-bind + (method-lambda method-args) + (make-method-lambda + gf (class-prototype method-class) + lambda-expression ()) + (let ((method (apply #'make-instance + method-class + :qualifiers qualifiers + :lambda-list lambda-list + :specializers specializers + :function (compile nil method-lambda) + method-args))) + (add-method gf method) + method))) + +#| +(defgeneric transform-specializer (specializer) + (:method (specializer) specializer) + (:method ((specializer class)) + (class-name specializer)) + (:method ((specializer eql-specializer)) + `(eql ,(eql-specializer-object specializer)))) +|# + +#-sbcl +(defun ensure-method (gf lambda-expression + &key (qualifiers ()) + (lambda-list (cadr lambda-expression)) + (specializers (required-args lambda-list (constantly 't)))) + (funcall (compile nil `(lambda () + (defmethod ,(generic-function-name gf) ,@qualifiers + ,(loop for specializer in specializers + for (arg . rest) on lambda-list + collect `(,arg ,specializer) into args + finally (return (nconc args rest))) + ,@(cddr lambda-expression)))))) + +;; The following ensures that effective slot definitions have a documentation in CMUCL. + +#+cmu +(defmethod compute-effective-slot-definition :around + ((class standard-class) name direct-slot-definitions) + (let ((effective-slot (call-next-method))) + (loop for direct-slot in direct-slot-definitions + for documentation = (documentation direct-slot 't) + when documentation do + (setf (documentation effective-slot 't) documentation) + (loop-finish)) + effective-slot)) + +;; The following can be used in direct-slot-definition-class to get the correct initargs +;; for a slot. Use it like this: +;; +;; (defmethod direct-slot-definition-class +;; ((class my-standard-class) &rest initargs) +;; (declare (dynamic-extent initargs)) +;; (destructuring-bind +;; (&key key-of-interest &allow-other-keys) +;; (fix-slot-initargs initargs) +;; ...)) + +(defvar *standard-slot-keys* + '(:name :documentation + :initargs :initform :initfunction + :readers :writers)) + +(defun fix-slot-initargs (initargs) + #+sbcl initargs + #+cmu + (let* ((counts (loop with counts + for (key nil) on initargs by #'cddr + do (incf (getf counts key 0)) + finally (return counts))) + (keys-to-fix (loop for (key value) on counts by #'cddr + if (> value 1) collect key))) + (if keys-to-fix + (let ((multiple-standard-keys + (intersection keys-to-fix *standard-slot-keys*))) + (if multiple-standard-keys + (error "Too many occurences of ~S in slot initargs ~S." + multiple-standard-keys initargs) + (loop with fixed-keys + for (key value) on initargs by #'cddr + if (member key keys-to-fix) + do (nconcf (getf fixed-keys key) (list value)) + else nconc (list key value) into fixed-initargs + finally (return (nconc fixed-initargs fixed-keys))))) + initargs))) + +;; In CMUCL, TYPEP and SUBTYPEP don't work as expected +;; in conjunction with class metaobjects. + +#-sbcl +(progn + (defgeneric typep (object type) + (:method (object type) + (cl:typep object type)) + (:method (object (type class)) + (cl:typep object (class-name type)))) + + (defgeneric subtypep (type1 type2) + (:method (type1 type2) + (cl:subtypep type1 type2)) + (:method ((type1 class) type2) + (cl:subtypep (class-name type1) type2)) + (:method (type1 (type2 class)) + (cl:subtypep type1 (class-name type2))) + (:method ((type1 class) (type2 class)) + (cl:subtypep (class-name type1) + (class-name type2))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew :closer-mop *features*))

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/release-notes.txt =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/release-notes.txt 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/release-notes.txt 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,34 @@ +Closer to MOP Release Note + +v0.0 initial release + +v0.1 +- separated single implementation into several ones, one for each MOP implementation / implementation family, in order to improve maintainability +- added support for LispWorks 4.4 +- removed extra method options from the LispWorks defmethod - it's a useful feature, but doesn't belong here +- the automatically generated slot accessor methods in LispWorks closed over the wrong slot names. fixed. (obsolete because of the next issue) +- In some cases, LispWorks deoptimizes slot access and reverts to the slot-value-using-class, etc., functions. This rendered the previously taken approach for fixing that protocol useless. Now, we have a much simpler fix. (Thanks to Jeff Caldwell.) Unfortunately, now some of the features that were previously fixed are missing again (correct initialization of accessor methods, accessor-method-slot-definition, reader-method-class and writer-method-class). Fortunately, LispWorks has already fixed those in 4.4, so this is no problem anymore in the long run. + +v0.2 +- The trick for reinitialization of generic-function-name or class-name in allegro, pcl, lispworks and mcl didn't work and had to be dropped. +- In clisp, defgeneric does call ensure-generic-function-using-class. This wasn't detected before due to a bug in mop-feature-tests. (Thanks to Bruno Haible.) +- Added the utility function ensure-method for programmatically creating methods, supported on all platforms. +- The defmethod macro for LispWorks didn't have an implicit block with the name of the generic function. Fixed. +- LispWorks 4.3 is not supported anymore. The existing conditionalizations are still available, though, and will be retained as long as they don't stand in the way of anything else. +- Since I have to override some symbols from the common-lisp package, I provide two utility packages closer-common-lisp and closer-common-lisp-user, similar to common-lisp and common-lisp-user but with all the MOP symbols added. The default packages additionally added by the various Common Lisp implementations are not added here. (I think that's cleaner.) +- Handling of pseudo-anonymous classes in CMU CL and SBCL had a copy&paste bug: The name was changed again in reinitialize-instance. +- TYPEP and SUBTYPEP don't work as expected in CMU CL and SBCL in conjunction with class metaobjects. Same for MCL, but for different reasons. So I have shadowed them and provide a new definition. (In CMU CL and SBCL, class metaobject are not considered types. In MCL, type information for class metaobjects is not available at some stages. Unfortunately, it doesn't seem to be possible to fix this with finalize-inheritance, so I have to revert to membership tests on the class precedence list.) +- MCL also doesn't like anonymous classes. So I have added a fix for that. +- I have incorrectly reported that MAKE-METHOD-LAMBDA is unreliable in CMU CL and SBCL. This was due to a bug in my test suite. However, it is required that the respective generic function and method metaobject classes and make-method-lambda definitions are part of the compilation environment when you want to use them. I have updated the respective sections in features.lisp and features.txt. +- Switched to an MIT/BSD-style license. + +v0.3 +- Now supports OpenMCL 1.0, LispWorks 4.4.6, SBCL 0.9.7 - 0.9.9, CMUCL 19C, Allegro 8.0, clisp 2.37 and 2.38. +- STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are now compatible in SBCL. This required some changes in the PCL support. +- Dropped the reports for LispWorks 4.3. +- Allegro 6.2 is not supported anymore. The existing conditionalizations are still available, though, and will be retained as long as they don't stand in the way of anything else. +- The incorrect specialization of slot-boundp-using-class and slot-makunbound-using-class on symbols instead of slot definition metaobjects in Allegro is fixed. +- SBCL 0.9.7 has improved a lot wrt MOP compatibility. This required some changes in the PCL support. +- The lack of extensible :allocation kinds in Allegro is fixed. (Covers 6.2, 7.0 and 8.0. Thanks to John Foderaro for giving me the important hint on how to solve this.) + +After version 0.3, there are no separate release notes anymore, but they will be generated automatically by darcs in the future.

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/supported-cls.txt =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/supported-cls.txt 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/supported-cls.txt 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,10 @@ +Allegro 7.0, 8.0 & 8.1 +CLisp 2.35 - 2.41 +CMU Common Lisp 19c, 19d +LispWorks 4.4.5, 4.4.6 Personal Edition +LispWorks 4.4.5, 4.4.6 Professional Edition +LispWorks 5.0, 5.0.1, Personal Edition +LispWorks 5.0 - 5.0.2, Professional Edition +Macintosh Common Lisp 5.1 +OpenMCL 1.0 +SBCL 0.9.16 - 0.9.18, 1.0.1 - 1.0.10

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/test/jeffs-code.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/test/jeffs-code.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/current/test/jeffs-code.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,207 @@ +;;; Jeff Caldwell 2004-04-16 +;;; LWL 4.3 +;;; +;;; To reproduce the issues I have come across: +;;; +;;; 1. (asdf:oos 'asdf:load-op 'closer-mop) +;;; 2. (compile-file "c2mop-attributes.lisp" :load t) +;;; 3. (in-package #:c2mop-test) +;;; C2MOP-TEST> (setq cr (make-instance 'credit-rating)) +;;; => Stack overflow (stack size 16000). +;;; +;;; (In this code, I accidently took out the format statements +;;; creating the output below. You may wish to put them back +;;; in the slot-value-using-class and (setf slot-value-using-class) +;;; methods at the bottom of this file.) +;;; +;;; slot-value-using-class class #<ATTRIBUTES-CLASS CREDIT-RATING 2134BF1C> +;;; object #<CREDIT-RATING 21732B2C> slot-name ALL-ATTRIBUTES-2382 +;;; slot-value-using-class class #<ATTRIBUTES-CLASS CREDIT-RATING 2134BF1C> +;;; object #<CREDIT-RATING 21732B2C> slot-name LEVEL +;;; slot-value-using-class class #<ATTRIBUTES-CLASS CREDIT-RATING 2134BF1C> +;;; object #<CREDIT-RATING 21732B2C> +;;; slot-name #<ATTRIBUTES-EFFECTIVE-SLOT-DEFINITION LEVEL 2134396C> +;;; slot-value-using-class class #<ATTRIBUTES-CLASS CREDIT-RATING 2134BF1C> +;;; object #<CREDIT-RATING 21732B2C> slot-name LEVEL +;;; slot-value-using-class class #<ATTRIBUTES-CLASS CREDIT-RATING 2134BF1C> +;;; object #<CREDIT-RATING 21732B2C> +;;; slot-name #<ATTRIBUTES-EFFECTIVE-SLOT-DEFINITION LEVEL 2134396C> +;;; slot-value-using-class class #<ATTRIBUTES-CLASS CREDIT-RATING 2134BF1C> +;;; object #<CREDIT-RATING 21732B2C> slot-name LEVEL +;;; slot-value-using-class class #<ATTRIBUTES-CLASS CREDIT-RATING 2134BF1C> +;;; object #<CREDIT-RATING 21732B2C> +;;; slot-name #<ATTRIBUTES-EFFECTIVE-SLOT-DEFINITION LEVEL 2134396C> +;;; ... +;;; +;;; Note that it alternates between slot-name LEVEL and +;;; slot-name #<ATTRIBUTES-EFFECTIVE-... +;;; +;;; In closer-mop.lisp change +;;; +;;; (cl:defmethod slot-value-using-class +;;; ((class standard-class) object (slot symbol)) +;;; (let ((slotd (find slot (class-slots class) :key #'slot-definition-name))) +;;; (if slotd +;;; (if (default-reader slotd) +;;; (slot-value-using-class class object slotd) +;;; (call-next-method)) +;;; (slot-missing class object slot 'slot-value)))) +;;; +;;; to +;;; +;;; ... +;;; (if slotd +;;; (if (default-reader slotd) +;;; (slot-value-using-class (find-class 'standard-class) +;;; object slotd) +;;; ... +;;; +;;; (I have no idea if that's a correct patch but it does stop +;;; the recursive stack overflow.) +;;; +;;; Then +;;; (asdf:oos 'asdf:load-op 'closer-mop) +;;; (setq cr (make-instance 'credit-rating) +;;; => +;;; The slot #<ATTRIBUTES-EFFECTIVE-SLOT-DEFINITION LEVEL 2133983C> is +;;; missing from #<CREDIT-RATING 206F0864> (of class #<ATTRIBUTES-CLASS +;;; CREDIT-RATING 2133B3DC>), when reading the value. +;;; +;;; At this point you also can remove the slot-value-using-class and +;;; setf slot-value-using-class methods. They were no-ops in this +;;; example, something I had run across in other code. I left them +;;; here to show the recursive stack overflow. Now that it is "fixed", +;;; we are left with the missing slot problem above. +;;; (The problem above is somewhat different from what I reported +;;; in my first email but the error above is what I'm getting now +;;; with this example.) +;;; +;;; Simply using the LW MOP, instead of using closer-mop, +;;; "fixes" the problem above. Quit using closer-mop and revert +;;; to the LW-only MOP. Change the defpackage to +;;; +;;; (defpackage #:c2mop-test +;;; (:use :cl :cl-user :clos)) +;;; +;;; (cl-user::quit) ;; Make really sure everything's fresh +;;; M-x slime +;;; (compile-file "c2mop-attributes.lisp" :load t) +;;; CL-USER> (in-package #:c2mop-test) +;;; #<PACKAGE C2MOP-TEST> +;;; C2MOP-TEST> (setq cr (make-instance 'credit-rating)) +;;; #<CREDIT-RATING 206EDFAC> +;;; C2MOP-TEST> (setf (level cr) 42) +;;; 42 +;;; C2MOP-TEST> (level cr) +;;; 42 +;;; C2MOP-TEST> (setf (slot-attribute cr 'level 'date-set) 20040416) +;;; 20040416 +;;; C2MOP-TEST> (slot-attribute cr 'level 'date-set) +;;; 20040416 +;;; + + +;;; +(defpackage #:c2mop-test +; (:use :cl :cl-user :clos) + (:use :cl :cl-user :closer-mop) + (:shadowing-import-from :closer-mop + #:defclass #:defmethod #:standard-class + #:ensure-generic-function #:defgeneric + #:standard-generic-function #:class-name) +) + +(in-package #:c2mop-test) + +(eval-when (:compile-toplevel :load-toplevel :execute) + +(defvar *all-attributes* (gensym "ALL-ATTRIBUTES-")) +(defvar *current-direct-slot-definitions* nil) + +(defclass attributes-class (standard-class) ()) + +(defclass attributes-mixin + (standard-slot-definition) + ((attributes :initarg :attributes :accessor slot-definition-attributes + :initform nil))) + +(defclass attributes-direct-slot-definition + (standard-direct-slot-definition attributes-mixin) + ()) + +(defclass attributes-effective-slot-definition + (standard-effective-slot-definition attributes-mixin) + ()) + +(defmethod effective-slot-definition-class ((class attributes-class) + &rest initargs) + (find-class 'attributes-effective-slot-definition)) + +(defmethod compute-effective-slot-definition ((class attributes-class) + name direct-slots) + (let* ((normal-slot (call-next-method))) + (setf (slot-definition-attributes normal-slot) + (remove-duplicates + (apply #'append (mapcar #'slot-definition-attributes + direct-slots)))) + normal-slot)) + +(defmethod direct-slot-definition-class + ((class attributes-class) &rest initargs) + (find-class 'attributes-direct-slot-definition)) + +(defmethod process-a-slot-option + ((class attributes-class) option value + already-processed-options slot) + (princ "process-a-slot-option") (princ option) + (if (eq option :attributes) + (list* :attributes `',value already-processed-options) + (call-next-method))) + +(defmethod compute-slots ((class attributes-class)) + (let* ((normal-slots (call-next-method)) + (alist (mapcar (lambda (slot) + (cons (slot-definition-name slot) + (mapcar (lambda (attr) (cons attr nil)) + (slot-definition-attributes + slot)))) + normal-slots))) + (cons (make-instance 'attributes-effective-slot-definition + :name *all-attributes* + :initform alist + :initfunction (lambda () alist)) + normal-slots))) + +(defun slot-attribute (instance slot-name attribute) + (cdr (slot-attribute-bucket instance slot-name attribute))) + +(defun (setf slot-attribute) (new-value instance slot-name attribute) + (setf (cdr (slot-attribute-bucket instance slot-name attribute)) + new-value)) + +(defun slot-attribute-bucket (instance slot-name attribute) + (let* ((all-buckets (slot-value instance *all-attributes*)) + (slot-bucket (assoc slot-name all-buckets))) + (unless slot-bucket + (error "Slot ~S of ~S has no attributes." + slot-name instance)) + (let ((attr-bucket (assoc attribute (cdr slot-bucket)))) + (unless attr-bucket + (error "Slot ~S of ~S has no attribute ~S." + slot-name instance attribute)) + attr-bucket))) + +(defmethod clos:slot-value-using-class + ((class attributes-class) object (slot-name attributes-effective-slot-definition)) + (call-next-method)) + +(defmethod (setf clos:slot-value-using-class) + (value (class attributes-class) object (slot-name attributes-effective-slot-definition)) + (call-next-method)) + +) ; eval-when + +(defclass credit-rating () + ((level :attributes (date-set time-set) :accessor level) + (desc :accessor desc)) + (:metaclass attributes-class))

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/inventories/20070421193107-dccf3-e9d51ab58efdffe18510bddafbfa450f276c224f.gz =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/inventories/20070421193107-dccf3-e9d51ab58efdffe18510bddafbfa450f276c224f.gz 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/inventories/20070421193107-dccf3-e9d51ab58efdffe18510bddafbfa450f276c224f.gz 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,239 @@ +[Initial revision (v0.2). +pc@p-cos.net**20050802151239] +[Class initialization patches. +pc@p-cos.net**20050816144718 + The correction of lists of direct superclasses was done at the wrong place (in :around methods on initialize-instance and reinitialize-instance). The MOP specification doesn't allow to define primary methods for initialize-instance and reinitialize-instance, but these are the only places where those lists can be corrected in a reasonable way. This affects LispWorks and MCL. + + Further changes: + - The typep implementation for MCL was incorrect. + - reinitialize-instance for standard-class could be simplified. + - reinitialize-instance for standard-generic-function could be simplified. +] +[Class initialization patch. +pc@p-cos.net**20050816231151 + The previous patch was partially incorrect. LispWorks and MCL don't need the change of the direct superclasses in primary methods on initialize-instance / reinitialize-instance. I have rearranged that part of the code back to what it was before. +] +[Checked with new versions of CLisp and SBCL. +pc@p-cos.net**20050904001359] +[Removed spurious &allow-other-keys declarations. +pc@p-cos.net**20050910092744] +[Minor edit. +pc@p-cos.net**20050910103331] +[Special cased defmethod macro for LispWorks. +pc@p-cos.net**20050910110130 + + The defmethod macro in LispWorks (i.e., the new definition in closer-mop) now checks whether only the default methods for make-method-lambda are applicable. If so, defmethod expands into an equivalent cl:defmethod form. This is a workaround to make keyword argument checking for standard generic functions work. + +] +[Changes triggered by Christophe Rhodes / SBCL. +pc@p-cos.net**20051029013651] +[Documentation update. +pc@p-cos.net**20051029115614] +[Supports OpenMCL 1.0 - no changes necessary. +pc@p-cos.net**20051029224040] +[Checked against LispWorks 4.4.6 - no changes. +pc@p-cos.net**20051103084956] +[Added reports for lack of extensible :allocation types. +pc@p-cos.net**20051105150436 + + See MOP Feature Tests for more details. + +] +[Rewired slot access protocol for slot-boundp-using-class and slot-makunbound-using-class in Allegro. +pc@p-cos.net**20051117200922] +[Updated reports on supported/fixed features and release notes. +pc@p-cos.net**20051117201142] +[CMUCL 19c now supports the dependent protocol correctly, so the corresponding fixes could be removed. +pc@p-cos.net**20051117201252] +[Added support for SBCL 0.9.7. +pc@p-cos.net**20051130202445] +[Checked against clisp 2.36. +pc@p-cos.net**20051205134118] +[Switched to symbols in the asdf definition. +pc@p-cos.net**20051220162014] +[Checked against SBCL 0.9.8. +pc@p-cos.net**20051228150237] +[Checked against clisp 2.37. +pc@p-cos.net**20060103112938] +[Fixed lack of extensible allocation kinds in Allegro Common Lisp. +pc@p-cos.net**20060119133808] +[Support for Allegro Common Lisp 8.0 added. (8.0b removed.) +pc@p-cos.net**20060119133914] +[TAG 0.3 +pc@p-cos.net**20060119202553] +[Fixed a bug in the loop form for some implementations of ensure-method. +pc@p-cos.net**20060127142634] +[Checked against clisp 2.38 and SBCL 0.9.9. +pc@p-cos.net**20060127142903] +[Replaced programmatic implementation of ensure-method in CMUCL and SBCL. +pc@p-cos.net**20060127142950 + + In CMUCL and SBCL, ensure-method was implemented as proposed in AMOP. However in some cases, this seems to lead to problems with method combination. For the time being, I have replaced the implementation by using a generated defmethod form instead, like in some of the other CL implementations. (In SBCL, this isn't as straightforward because SBCL doesn't accept class metaobjects as specializers.) +] +[Added a utility function required-args. +pc@p-cos.net**20060127214635] +[Documented the results of the more detailed checks for metaobject readers in MOP Feature Tests. +pc@p-cos.net**20060201000120] +[The function documentation now returns the documentation strings for slot definition metaobjects in OpenMCL. +pc@p-cos.net**20060201000253] +[The function documentation now returns the documentation strings for effective slot definition metaobjects in CMUCL. +pc@p-cos.net**20060201000433] +[Finalized the separate release notes. +pc@p-cos.net**20060201000511] +[TAG 0.31 +pc@p-cos.net**20060203120853] +[Added reports about the results of the tests whether subclasses of specified metaobject classes inherit any exported slots. See MOP Feature Tests for more details. +pc@p-cos.net**20060211193158] +[Changed system def to handle ASDF-Install bug +Gary King gwking@metabang.com**20051216174627] +[Updated system defs because MCL is disappearing from OpenMCL's features list +Gary King gwking@metabang.com**20060216145216] +[Removed a conflict between Gary's and my code. +pc@p-cos.net**20060224212121] +[Updated more code to reflect the disappearance of MCL from OpenMCL's feature list +pc@p-cos.net**20060224212657] +[Checked against SBCL 0.9.10 - no changes, except for a few specified metaclass that don't define slots with exported symbols anymore. +pc@p-cos.net**20060301115916] +[Updated the version number and copyright information in the system definition. +pc@p-cos.net**20060301200956] +[Removed a superfluous export from clisp's c2mop. +pc@p-cos.net**20060302093912] +[Recorded the results from running MOP Feature Tests on ECL. +pc@p-cos.net**20060325171005] +[Checked against SBCL 0.9.11. SBCL is now safe from making subclasses of specified metaobject classes inherit slots that they shouldn't see. +pc@p-cos.net**20060327120633] +[Checked againts SBCL 0.9.12 - no changes. +pc@p-cos.net**20060427163929] +[Added support for ecl. +pc@p-cos.net**20060501082945] +[Checked against SBCL 0.9.13 - no changes. +pc@p-cos.net**20060529180600] +[Added the standard accessor classes to ecl. +pc@p-cos.net**20060531202150] +[Changed a slot name in the class eql-specializer* in LispWorks that was previously accessible in commen-lisp-user. +pc@p-cos.net**20060531203220] +[Checked against sbcl 0.9.14 - no changes. +pc@p-cos.net**20060629175352] +[MCL and OpenMCL don't reinitialize argument-precedence-order properly when a lambda list of a generic function is reinitialized. +pc@p-cos.net**20060711121904] +[Updated the reports for :reinitialize-instance-calls-finalize-inheritance. See MOP Feature Tests for more details. +pc@p-cos.net**20060720085220] +[Added a new utility function ensure-finalized. +pc@p-cos.net**20060720105100 + + A pretty common idiom is this: + + (unless (class-finalized-p class) + (finalize-inheritance class)) + class + + This is captured in the new utility function ensure-finalized. + +] +[Checked against clisp 2.39 - no changes. +pc@p-cos.net**20060720105302] +[Updated report for :reinitialize-instance-calls-finalize-inheritance. +pc@p-cos.net**20060721125623] +[TAG 0.32 +pc@p-cos.net**20060729125750] +[Checked against sbcl 0.9.15 - several changes. +pc@p-cos.net**20060729134152 + + SBCL 0.9.15 now has support for anonymous classes and correctly calls finalize-inheritance when reinitialize-instance is invoked on a class metaobject. + + This makes several changes necessary in the Closer to MOP support for SBCL. Therefore, support for versions of SBCL before 0.9.15 is dropped. The darcs repository has been tagged with '0.32' in case you need a version that works on older SBCL versions, up to and including SBCL 0.9.14. + +] +[SBCL 0.9.15 now correctly supports typep and subtypep for class metaobjects, so Closer to MOP's versions thereof are not needed anymore. +pc@p-cos.net**20060729134711] +[Class metaobjects in SBCL can be anonymous now, so we don't have to force a generated name. +pc@p-cos.net**20060729134940] +[Removed a spurious call to print. +pc@p-cos.net**20060729135119] +[SBCL now supports class metaobjects in specializers in defmethod forms, so we don't have to replace them with their names. +pc@p-cos.net**20060729135149] +[Noted support for clisp 2.39. +pc@p-cos.net**20060729135435] +[Fixed features.txt: it still claimed that SBCL had a problem with calling finalize-inheritance again. +pc@p-cos.net**20060802122101] +[Removed a spurious in-package declaration in the .asd file. +pc@p-cos.net**20060821203834] +[TAG 0.33 +pc@p-cos.net**20060826084425] +[Checked against sbcl 0.9.16 - several changes. +pc@p-cos.net**20060826103957 + + SBCL 0.9.16 now passes all MOP Feature Tests. + + This makes several changes necessary in the Closer to MOP support for SBCL, again. Therefore, support for SBCL 0.9.15 is dropped. The darcs repository has been tagged with '0.33' in case you need a version that works with SBCL 0.9.15. + +] +[TAG 0.4 +pc@p-cos.net**20060826124935] +[Updated version number in the .asd file. +pc@p-cos.net**20060826130127] +[Checked against SBCL 0.9.17 - no changes. +pc@p-cos.net**20060927161258] +[Checked against clisp 2.40. REINITIALIZE-INSTANCE now calls FINALIZE-INHERITANCE correctly in clisp. +pc@p-cos.net**20061001221204] +[Fixed a problem in the handling of initial-methods in LispWorks. +pc@p-cos.net**20061010173021] +[Fixed another issue with initial-methods in LispWorks. +pc@p-cos.net**20061010174147] +[Checked against clisp 2.41 - no changes. +pc@p-cos.net**20061013081525] +[Added support for LispWorks 5.0 - numerous changes. +pc@p-cos.net**20061014113836] +[Fixed a bug in some (loop var on list ...) idioms. Thanks to Attila Lendvai. +pc@p-cos.net**20061028113627] +[Checked against sbcl 0.9.18 - no changes. +pc@p-cos.net**20061031090315] +[Checked against CMU 19d - no changes. +pc@p-cos.net**20061116132730] +[Checked against SBCL 1.0. Modified ensure-method for SBCL. +pc@p-cos.net**20061130202814 + + The programmatic version of ensure-method in SBCL has problems again. Therefore, it is replaced with a version that evaluates a defmethod form for the time being. +] +[Noted support for SBCL 1.0. +pc@p-cos.net**20061130203424] +[Checked against LispWorks 5.0.1. No changes. +pc@p-cos.net**20061218222443] +[Noted support for SBCL 1.0. +pc@p-cos.net**20061218222546] +[Checked against SBCL 1.0.1. Reinstated the former ensure-method implementation for SBCL. +pc@p-cos.net**20061227142245] +[Simplified the implementation of some validate-superclass methods. (Reduced consing.) +pc@p-cos.net**20061228002510] +[Exported set-funcallable-instance-function in ecl and OpenMCL. +pc@p-cos.net**20061228002726] +[Changed the format of the contents of features.lisp. Better support for comparing feature changes between different versions of a given CL implementation. +pc@p-cos.net**20061228002856] +[Corrected and added a few feature reports to features.txt. +pc@p-cos.net**20061228003007] +[Updated version number in the .asd file. +pc@p-cos.net**20061228151904] +[TAG 0.41 +pc@p-cos.net**20061228151916] +[Noted lack of use of FUNCALLABLE-STANDARD-OBJECT as the default superclass for FUNCALLABLE-STANDARD-CLASS in Allegro Common Lisp. +pc@p-cos.net**20061228161029] +[Noted support for SBCL 1.0.1. +pc@p-cos.net**20061228161128] +[Checked against SBCL 1.0.2 - no changes. +pc@p-cos.net**20070127192325] +[Noted support for SBCL 1.0.1 and 1.0.2. +pc@p-cos.net**20070127192925] +[Checked against LispWorks 5.0.1 Personal Edition - no changes. +pc@p-cos.net**20070127195002] +[Fixed a typo in the SBCL version numbers. +pc@p-cos.net**20070127201814] +[Fixed a bug in the creation of congruent lambda lists for generic functions in c2mop for LispWorks. +pc@p-cos.net**20070206104737] +[Checked against SBCL 1.0.3 - no changes. +pc@p-cos.net**20070228193530] +[Checked against SBCL 1.0.4 - no changes. +pc@p-cos.net**20070327202949] +[Checked against LispWorks 5.0.2 - no changes. +pc@p-cos.net**20070421192516] +[Incremented version number to 0.42. +pc@p-cos.net**20070421193020] \ No newline at end of file

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/inventory =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/inventory 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/inventory 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,21 @@ +Starting with tag: +[TAG 0.42 +pc@p-cos.net**20070421193107] +[Checked against SBCL 1.0.5 - no changes. +pc@p-cos.net**20070501115057] +[Checked against SBCL 1.0.6 - no changes. +pc@p-cos.net**20070528145132] +[Checked against SBCL 1.0.7 - no changes. +pc@p-cos.net**20070628201619] +[Checked against SBCL 1.0.8 and 1.0.9 - no changes. +pc@p-cos.net**20070831233438] +[Fixed a copy&paste bug in the description for funcallable instances for MCL and OpenMCL. +pc@p-cos.net**20070916181018] +[Checked against SBCL 1.0.10 - no changes. +pc@p-cos.net**20070926164316] +[Checked against Allegro 8.1. Dropped fix for SLOT-BOUNDP-USING-CLASS for that version. +pc@p-cos.net**20070926172622 + + SLOT-BOUNDP-USING-CLASS now works correctly by default in Allegro 8.1. + +] \ No newline at end of file

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20050802151239-dccf3-e268d42f1d0bfb9c7ef64135393a2f63b243ed54.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20050802151239-dccf3-e268d42f1d0bfb9c7ef64135393a2f63b243ed54.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20050816144718-dccf3-c8e542ff6d11161f8c50c8595710590711c6732b.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20050816144718-dccf3-c8e542ff6d11161f8c50c8595710590711c6732b.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20050816231151-dccf3-e3829cce37824704fb39f3cafdc3c6a92f2d3cf3.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20050816231151-dccf3-e3829cce37824704fb39f3cafdc3c6a92f2d3cf3.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20050904001359-dccf3-914880d9d7054a58ddf886f661065a9352df6e08.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20050904001359-dccf3-914880d9d7054a58ddf886f661065a9352df6e08.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20050910092744-dccf3-87b02abfabbf534e03e82a45a96521a1d7c7a3b2.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20050910092744-dccf3-87b02abfabbf534e03e82a45a96521a1d7c7a3b2.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20050910103331-dccf3-6311e556632ec0e01cc952b75171e77536716c0c.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20050910103331-dccf3-6311e556632ec0e01cc952b75171e77536716c0c.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20050910110130-dccf3-c6296b87c9e0e39bf7e938444dbd278fbba606c3.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20050910110130-dccf3-c6296b87c9e0e39bf7e938444dbd278fbba606c3.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051029013651-dccf3-b4be9c6147a26c1e9767e9951f49aee2c898655b.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051029013651-dccf3-b4be9c6147a26c1e9767e9951f49aee2c898655b.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051029115614-dccf3-65351c2ca451aceaa696ac89c9c8223199afae00.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051029115614-dccf3-65351c2ca451aceaa696ac89c9c8223199afae00.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051029224040-dccf3-98657977f7a5a7dc1dce7fc2b536413116b1e9cb.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051029224040-dccf3-98657977f7a5a7dc1dce7fc2b536413116b1e9cb.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051103084956-dccf3-bc5ad826d6d0c656f1e9f7af023c238ad5a5fade.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051103084956-dccf3-bc5ad826d6d0c656f1e9f7af023c238ad5a5fade.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051105150436-dccf3-42c062a8ce5e51a74d47911cbf0aed17761f25d3.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051105150436-dccf3-42c062a8ce5e51a74d47911cbf0aed17761f25d3.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051117200922-dccf3-2a2e5386869e5788124740a6796aa8d93fe88a07.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051117200922-dccf3-2a2e5386869e5788124740a6796aa8d93fe88a07.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051117201142-dccf3-2700459573f278c02078ef40150f7d92fcb4ed5a.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051117201142-dccf3-2700459573f278c02078ef40150f7d92fcb4ed5a.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051117201252-dccf3-5469d4a6ff03e37238daa28708a8727f2f88fdd9.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051117201252-dccf3-5469d4a6ff03e37238daa28708a8727f2f88fdd9.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051130202445-dccf3-d3d97662bf9052129efdf34c4af8cb75d437eb27.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051130202445-dccf3-d3d97662bf9052129efdf34c4af8cb75d437eb27.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051205134118-dccf3-8045f8a6023f1067bf862213cd46cd07363ce091.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051205134118-dccf3-8045f8a6023f1067bf862213cd46cd07363ce091.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051216174627-3cc5d-3c778eca546a1cdb364885cd436fc275f71cb71e.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051216174627-3cc5d-3c778eca546a1cdb364885cd436fc275f71cb71e.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051220162014-dccf3-5541c25791f62d836e27802984f53014e2cfc72e.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051220162014-dccf3-5541c25791f62d836e27802984f53014e2cfc72e.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051228150237-dccf3-fc2c4ab8e8c0798d200109ffc20b79259c28258c.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20051228150237-dccf3-fc2c4ab8e8c0798d200109ffc20b79259c28258c.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060103112938-dccf3-2f91b0e195aba3b348283c9c21f36d356db9d32b.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060103112938-dccf3-2f91b0e195aba3b348283c9c21f36d356db9d32b.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060119133808-dccf3-905164dbf83a727c6875e534c8afc7712adde1e2.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060119133808-dccf3-905164dbf83a727c6875e534c8afc7712adde1e2.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060119133914-dccf3-df1b6582ea4210cf1a697b8c75238342e465d444.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060119133914-dccf3-df1b6582ea4210cf1a697b8c75238342e465d444.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060119202553-dccf3-9e87c4d4d342a8a7fe01167b143ed5e67a08fa8c.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060119202553-dccf3-9e87c4d4d342a8a7fe01167b143ed5e67a08fa8c.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060127142634-dccf3-0cbc9730e904db90c5598f37d28ed2a5d01e8060.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060127142634-dccf3-0cbc9730e904db90c5598f37d28ed2a5d01e8060.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060127142903-dccf3-114489c1437896299eba5cb5e1abcdcee3588f4d.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060127142903-dccf3-114489c1437896299eba5cb5e1abcdcee3588f4d.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060127142950-dccf3-a9161a505f3d6fc1376d2e9d065da70c59ec99e2.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060127142950-dccf3-a9161a505f3d6fc1376d2e9d065da70c59ec99e2.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060127214635-dccf3-a6d51c1d634b093f9403635cb3ec6230bba703b1.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060127214635-dccf3-a6d51c1d634b093f9403635cb3ec6230bba703b1.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060201000120-dccf3-b4333796ffe0fe6f5c99603b29cc995508b8dcae.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060201000120-dccf3-b4333796ffe0fe6f5c99603b29cc995508b8dcae.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060201000253-dccf3-6886af50a43d5a624a196f587acf8ef183c6946d.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060201000253-dccf3-6886af50a43d5a624a196f587acf8ef183c6946d.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060201000433-dccf3-825ddee7bae9c308010ec376b13fe5d4038687d5.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060201000433-dccf3-825ddee7bae9c308010ec376b13fe5d4038687d5.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060201000511-dccf3-b67c903a0922806dde28834fef9548e1a19450df.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060201000511-dccf3-b67c903a0922806dde28834fef9548e1a19450df.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060203120853-dccf3-d772fe3f3f39f4c7114b18ba7dd1ce5c4eaf1896.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060203120853-dccf3-d772fe3f3f39f4c7114b18ba7dd1ce5c4eaf1896.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060211193158-dccf3-4534d4b849a303f855c692e41232ca1db1c18614.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060211193158-dccf3-4534d4b849a303f855c692e41232ca1db1c18614.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060216145216-3cc5d-508513582f98be0b13ac28491b590ae926133b98.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060216145216-3cc5d-508513582f98be0b13ac28491b590ae926133b98.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060224212121-dccf3-4e71a819e03eb87e7e41b8bbb88758857ff26099.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060224212121-dccf3-4e71a819e03eb87e7e41b8bbb88758857ff26099.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060224212657-dccf3-068ab07c914a910ead2cf314711aec15c95b3f47.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060224212657-dccf3-068ab07c914a910ead2cf314711aec15c95b3f47.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060301115916-dccf3-319e857c38bf42decd2c98fc3df4208011590dd2.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060301115916-dccf3-319e857c38bf42decd2c98fc3df4208011590dd2.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060301200956-dccf3-d0315e6cf06746cfa4d2f9aae97af7ff6b95f979.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060301200956-dccf3-d0315e6cf06746cfa4d2f9aae97af7ff6b95f979.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060302093912-dccf3-77419535e33067767884542db7d015cfccb3ac61.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060302093912-dccf3-77419535e33067767884542db7d015cfccb3ac61.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060325171005-dccf3-c26bf0552b60f9e02107614b0fd23b84650b82c6.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060325171005-dccf3-c26bf0552b60f9e02107614b0fd23b84650b82c6.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060327120633-dccf3-c7f73a665f3f8fcd0d666ae7a08eaa1d586e6be5.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060327120633-dccf3-c7f73a665f3f8fcd0d666ae7a08eaa1d586e6be5.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060427163929-dccf3-7c2b0e9aa58e3f5a27375162e099f2c8451137ca.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060427163929-dccf3-7c2b0e9aa58e3f5a27375162e099f2c8451137ca.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060501082945-dccf3-f330509c7bf886ad34c63a9fa7386a0a458b34ac.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060501082945-dccf3-f330509c7bf886ad34c63a9fa7386a0a458b34ac.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060529180600-dccf3-62cfd9621e1802d45cd4459d96f367f7a10b5ca1.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060529180600-dccf3-62cfd9621e1802d45cd4459d96f367f7a10b5ca1.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060531202150-dccf3-686d5ba89231851614891f21e29033003105888d.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060531202150-dccf3-686d5ba89231851614891f21e29033003105888d.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060531203220-dccf3-32e3cf5199ceaf2d34b7b9ed3732e923b6a6de53.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060531203220-dccf3-32e3cf5199ceaf2d34b7b9ed3732e923b6a6de53.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060629175352-dccf3-2a287976284aa6a523d7918f4747cf593174ebe7.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060629175352-dccf3-2a287976284aa6a523d7918f4747cf593174ebe7.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060711121904-dccf3-e427b977f9fa61ac7615b3f9266b3c09f6ab394c.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060711121904-dccf3-e427b977f9fa61ac7615b3f9266b3c09f6ab394c.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060720085220-dccf3-8733e01e9790f1929009378878359e13931ff231.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060720085220-dccf3-8733e01e9790f1929009378878359e13931ff231.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060720105100-dccf3-7d147f9c086e13bd2b83e670953ac124ec7dcb27.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060720105100-dccf3-7d147f9c086e13bd2b83e670953ac124ec7dcb27.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060720105302-dccf3-70b8a60a40352e9ffa430467b36b41d9e785561b.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060720105302-dccf3-70b8a60a40352e9ffa430467b36b41d9e785561b.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060721125623-dccf3-c9a6e3c8ab13d7545401922436152ef6039f35b8.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060721125623-dccf3-c9a6e3c8ab13d7545401922436152ef6039f35b8.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060729125750-dccf3-677f12862b02fb3e369b3855c7a82fc9c9f07e28.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060729125750-dccf3-677f12862b02fb3e369b3855c7a82fc9c9f07e28.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060729134152-dccf3-ee40ebb2ef710ff23053b2765dfd8f5e5adeeb5b.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060729134152-dccf3-ee40ebb2ef710ff23053b2765dfd8f5e5adeeb5b.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060729134711-dccf3-dbcf08303fe3f2e8ad195382c90e88cb5fa0fda7.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060729134711-dccf3-dbcf08303fe3f2e8ad195382c90e88cb5fa0fda7.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060729134940-dccf3-c4c1848e22a3d8293090441fd1a1b39670067107.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060729134940-dccf3-c4c1848e22a3d8293090441fd1a1b39670067107.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060729135119-dccf3-62cbac84437b668d5c7b4222d3ffcd9b743a2067.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060729135119-dccf3-62cbac84437b668d5c7b4222d3ffcd9b743a2067.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060729135149-dccf3-615006dc944f3c9c6e15b57467e597f67a40ad77.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060729135149-dccf3-615006dc944f3c9c6e15b57467e597f67a40ad77.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060729135435-dccf3-a6554658258dcdada3b08ad08e6dd17657c7c974.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060729135435-dccf3-a6554658258dcdada3b08ad08e6dd17657c7c974.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060802122101-dccf3-c0ae6510f6436c0fb88bb5ff92a25c9ae529ad17.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060802122101-dccf3-c0ae6510f6436c0fb88bb5ff92a25c9ae529ad17.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060821203834-dccf3-d6305a3e3412ff99beace007948dafc3100e1d6e.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060821203834-dccf3-d6305a3e3412ff99beace007948dafc3100e1d6e.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060826084425-dccf3-1cb35238f9645cd1d5d4e477a9234fc583e0dc6f.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060826084425-dccf3-1cb35238f9645cd1d5d4e477a9234fc583e0dc6f.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060826103957-dccf3-4bfdc272ae29918f08b54d0bdc14fed29b443814.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060826103957-dccf3-4bfdc272ae29918f08b54d0bdc14fed29b443814.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060826124935-dccf3-2a4546691b80a18783c5421d46ac3d72a2c252fb.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060826124935-dccf3-2a4546691b80a18783c5421d46ac3d72a2c252fb.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060826130127-dccf3-eec66c0522b0ab74d72bfdd61250f0ffaae584c6.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060826130127-dccf3-eec66c0522b0ab74d72bfdd61250f0ffaae584c6.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060927161258-dccf3-649ad24438070167a2f0100bb9b8f62601147f6d.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20060927161258-dccf3-649ad24438070167a2f0100bb9b8f62601147f6d.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061001221204-dccf3-56ed441636d15f7f23de7b76b6be8222fb9b67f8.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061001221204-dccf3-56ed441636d15f7f23de7b76b6be8222fb9b67f8.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061010173021-dccf3-159ee4ddbabc437a75ebf561e3301e92327dadf2.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061010173021-dccf3-159ee4ddbabc437a75ebf561e3301e92327dadf2.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061010174147-dccf3-d08093855647506dfbfe1c8263a3555f7a08541a.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061010174147-dccf3-d08093855647506dfbfe1c8263a3555f7a08541a.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061013081525-dccf3-fe4c6c81952c166149c00b1fe0df0834743ea370.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061013081525-dccf3-fe4c6c81952c166149c00b1fe0df0834743ea370.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061014113836-dccf3-f117c253f5ab3d478f32c411f076a5b9d90f28be.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061014113836-dccf3-f117c253f5ab3d478f32c411f076a5b9d90f28be.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061028113627-dccf3-5f62832804d6c3dc544bd00341a7551fce46af78.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061028113627-dccf3-5f62832804d6c3dc544bd00341a7551fce46af78.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061031090315-dccf3-42d2030266347debf49e4bf88a13abdcffb4eac1.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061031090315-dccf3-42d2030266347debf49e4bf88a13abdcffb4eac1.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061116132730-dccf3-e92c87581e04f60c7a029bbe6d7cdd6958319ff7.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061116132730-dccf3-e92c87581e04f60c7a029bbe6d7cdd6958319ff7.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061130202814-dccf3-3120d1936aca4182a1f8fd2e9076e84e1404d7d5.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061130202814-dccf3-3120d1936aca4182a1f8fd2e9076e84e1404d7d5.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061130203424-dccf3-74301ed5df59c70046119acac59c5ceef0c00ecf.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061130203424-dccf3-74301ed5df59c70046119acac59c5ceef0c00ecf.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061218222443-dccf3-edde41dbcc6152e160bfc02201985e577adc11b0.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061218222443-dccf3-edde41dbcc6152e160bfc02201985e577adc11b0.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061218222546-dccf3-81a4963703b080a4230de18285fcc7f4f8f076a8.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061218222546-dccf3-81a4963703b080a4230de18285fcc7f4f8f076a8.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061227142245-dccf3-9eee2aa05227bdf4f4eeaf45e58c845a4707ffff.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061227142245-dccf3-9eee2aa05227bdf4f4eeaf45e58c845a4707ffff.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228002510-dccf3-163cba8d0d6e4c7548bcac17463887b52d482b11.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228002510-dccf3-163cba8d0d6e4c7548bcac17463887b52d482b11.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228002726-dccf3-2abe813153b4868c6219d045cba84119bbe37b62.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228002726-dccf3-2abe813153b4868c6219d045cba84119bbe37b62.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228002856-dccf3-af055d64a95a072906b14cf1713d04f171fae53d.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228002856-dccf3-af055d64a95a072906b14cf1713d04f171fae53d.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228003007-dccf3-19d3d52b67d6752806ade229cc573df39fefd736.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228003007-dccf3-19d3d52b67d6752806ade229cc573df39fefd736.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228151904-dccf3-ef3232d3763a7a5fcfd18bd92b289590e8dfbb77.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228151904-dccf3-ef3232d3763a7a5fcfd18bd92b289590e8dfbb77.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228151916-dccf3-82758310329d2019305d44c787c6ff559720c202.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228151916-dccf3-82758310329d2019305d44c787c6ff559720c202.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228161029-dccf3-89435e9661c27dc9251269f3e035574cce8ccc6b.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228161029-dccf3-89435e9661c27dc9251269f3e035574cce8ccc6b.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228161128-dccf3-0adc1e659006165544e9d15583841f321aca1b4e.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20061228161128-dccf3-0adc1e659006165544e9d15583841f321aca1b4e.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070127192325-dccf3-d77060b4d6264e601b0a0456c59bc0f9b6b39d42.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070127192325-dccf3-d77060b4d6264e601b0a0456c59bc0f9b6b39d42.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070127192925-dccf3-0f0f5a0c26d9089334b2f54ae13cea2ddc4cd881.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070127192925-dccf3-0f0f5a0c26d9089334b2f54ae13cea2ddc4cd881.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070127195002-dccf3-314892775fb8ae67ee688777168326daba80b565.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070127195002-dccf3-314892775fb8ae67ee688777168326daba80b565.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070127201814-dccf3-128f7776110f2b6673a72a9e5c97d3a090cd028f.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070127201814-dccf3-128f7776110f2b6673a72a9e5c97d3a090cd028f.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070206104737-dccf3-e8605c338153ef4cfca23e2691bdbd8220ed9c17.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070206104737-dccf3-e8605c338153ef4cfca23e2691bdbd8220ed9c17.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070228193530-dccf3-b0fe50e904a9f06b680ab19c79d5e375c45bb4e1.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070228193530-dccf3-b0fe50e904a9f06b680ab19c79d5e375c45bb4e1.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070327202949-dccf3-77b1abaa2cd6661419f04d3c1422ee0e4970e2d5.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070327202949-dccf3-77b1abaa2cd6661419f04d3c1422ee0e4970e2d5.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070421192516-dccf3-13d712262e80609ffa3e44656a11ddf1eb8c5ba2.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070421192516-dccf3-13d712262e80609ffa3e44656a11ddf1eb8c5ba2.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070421193020-dccf3-46cccd00d206b252681348edde6d08b9f8c12744.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070421193020-dccf3-46cccd00d206b252681348edde6d08b9f8c12744.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070421193107-dccf3-e9d51ab58efdffe18510bddafbfa450f276c224f.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070421193107-dccf3-e9d51ab58efdffe18510bddafbfa450f276c224f.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070501115057-dccf3-fd3901cf565e463eddafaf82e6f526d9403f5f29.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070501115057-dccf3-fd3901cf565e463eddafaf82e6f526d9403f5f29.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070528145132-dccf3-e1d978c1cd424af7cfabb1d036d07a10a7a4ed62.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070528145132-dccf3-e1d978c1cd424af7cfabb1d036d07a10a7a4ed62.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070628201619-dccf3-6697990e3daa875937fba6209b49f9700ce5f98f.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070628201619-dccf3-6697990e3daa875937fba6209b49f9700ce5f98f.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070831233438-dccf3-551d9afcedf44d0735b330c50be407619f4cb8e0.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070831233438-dccf3-551d9afcedf44d0735b330c50be407619f4cb8e0.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070916181018-dccf3-e11c738d92d8e1b2dbc979a10f258a647e164022.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070916181018-dccf3-e11c738d92d8e1b2dbc979a10f258a647e164022.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070926164316-dccf3-0399c8966f70466f0bb3f1abd28f14b7698f542f.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070926164316-dccf3-0399c8966f70466f0bb3f1abd28f14b7698f542f.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070926172622-dccf3-0c2318248afb60197e6986c33794e0f97e43cfa2.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/closer-mop/_darcs/patches/20070926172622-dccf3-0c2318248afb60197e6986c33794e0f97e43cfa2.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/prefs/binaries =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/prefs/binaries 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/prefs/binaries 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,39 @@ +# Binary file regexps: +.png$ +.PNG$ +.gz$ +.GZ$ +.pdf$ +.PDF$ +.jpg$ +.JPG$ +.gif$ +.GIF$ +.tar$ +.TAR$ +.bz2$ +.BZ2$ +.z$ +.Z$ +.zip$ +.ZIP$ +.jar$ +.JAR$ +.so$ +.SO$ +.a$ +.A$ +.tgz$ +.TGZ$ +.jpeg$ +.JPEG$ +.mpg$ +.MPG$ +.mpeg$ +.MPEG$ +.iso$ +.ISO$ +.exe$ +.EXE$ +.doc$ +.DOC$

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/prefs/boring =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/prefs/boring 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/prefs/boring 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,34 @@ +# Boring file regexps: +.hi$ +.o$ +.o.cmd$ +# *.ko files aren't boring by default because they might +# be Korean translations rather than kernel modules. +# .ko$ +.ko.cmd$ +.mod.c$ +(^|/).tmp_versions($|/) +(^|/)CVS($|/) +(^|/)RCS($|/) +~$ +#(^|/).[^/] +(^|/)_darcs($|/) +.bak$ +.BAK$ +.orig$ +(^|/)vssver.scc$ +.swp$ +(^|/)MT($|/) +(^|/){arch}($|/) +(^|/).arch-ids($|/) +(^|/), +.class$ +.prof$ +(^|/).DS_Store$ +(^|/)BitKeeper($|/) +(^|/)ChangeSet($|/) +(^|/).svn($|/) +.py[co]$ +# +.cvsignore$ +(^|/)Thumbs.db$

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/prefs/defaultrepo =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/prefs/defaultrepo 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/prefs/defaultrepo 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1 @@ +http://common-lisp.net/project/closer/repos/closer-mop

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/prefs/motd ===================================================================

Added: branches/trunk-reorg/thirdparty/closer-mop/_darcs/prefs/repos =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/_darcs/prefs/repos 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/_darcs/prefs/repos 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1 @@ +http://common-lisp.net/project/closer/repos/closer-mop

Added: branches/trunk-reorg/thirdparty/closer-mop/allegro/closer-mop-packages.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/allegro/closer-mop-packages.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/allegro/closer-mop-packages.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,190 @@ +(in-package :cl-user) + +(defpackage #:closer-mop + (:use #:common-lisp #:lispworks) + (:nicknames #:c2mop) + + (:shadow + #:defclass #:defgeneric #:ensure-generic-function + #:standard-class #:standard-generic-function) + (:export + #:defclass #:defgeneric #:ensure-generic-function + #:standard-class #:standard-generic-function) + + (:import-from #:mop + + #:direct-slot-definition + #:effective-slot-definition + #:eql-specializer + #:forward-referenced-class + #:funcallable-standard-class + #:funcallable-standard-object + #:metaobject + #:slot-definition + #:specializer + #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + + #:accessor-method-slot-definition + #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #:eql-specializer-object + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #:find-method-combination + #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #:intern-eql-specializer + #-allegro #:make-method-lambda + #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #:reader-method-class + #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #:specializer-direct-generic-functions + #:specializer-direct-methods + #:standard-instance-access + #:update-dependent + #:validate-superclass + #:writer-method-class) + + (:export + #:direct-slot-definition + #:effective-slot-definition + #:eql-specializer + #:forward-referenced-class + #:funcallable-standard-class + #:funcallable-standard-object + #:metaobject + #:slot-definition + #:specializer + #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + + #:ensure-finalized + #:ensure-method + #:fix-slot-initargs + #:required-args + + #:accessor-method-slot-definition + #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #:eql-specializer-object + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #:find-method-combination + #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #:intern-eql-specializer + #-allegro #:make-method-lambda + #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #:reader-method-class + #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #:specializer-direct-generic-functions + #:specializer-direct-methods + #:standard-instance-access + #:update-dependent + #:validate-superclass + #:writer-method-class))

Added: branches/trunk-reorg/thirdparty/closer-mop/allegro/closer-mop.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/allegro/closer-mop.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/allegro/closer-mop.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,197 @@ +(in-package :closer-mop) + +;; Some utility functions. + +(defun required-args (lambda-list &optional (collector #'identity)) + (loop for arg in lambda-list + until (member arg lambda-list-keywords) + collect (funcall collector arg))) + +(defun ensure-finalized (class &optional (errorp t)) + (if (typep class 'class) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (when errorp (error "~S is not a class." class))) + class) + +;; We need a new standard-class for various things. + +(cl:defclass standard-class (cl:standard-class) + ((valid-slot-allocations :initform '(:instance :class) + :accessor valid-slot-allocations + :reader excl::valid-slot-allocation-list))) + +;; validate-superclass for metaclass classes is a little bit +;; more tricky than for class metaobject classes because +;; we don't want to make all standard-classes compatible to +;; each other. + +;; Our validate-superclass may get passed a class-prototype +;; as its second argument, so don't expect its readers to +;; yield useful information. (In ANSI parlance, "the +;; consequences are undefined...") + +(cl:defmethod validate-superclass + ((class standard-class) + (superclass cl:standard-class)) + (or (when (eq (class-of class) (find-class 'standard-class)) + (or (eq (class-of superclass) (find-class 'cl:standard-class)) + (eq (class-of superclass) (find-class 'standard-class)))) + (call-next-method) + (when (eq (class-of superclass) (find-class 'cl:standard-class)) + (validate-superclass class (class-prototype (find-class 'standard-class)))))) + +;; The following macro ensures that the new standard-class is used by default. + +(defmacro defclass (name (&rest supers) &body options) + (if (member :metaclass options :key #'car) + `(cl:defclass ,name ,supers ,@options) + `(cl:defclass ,name ,supers ,@options + (:metaclass standard-class)))) + +;; Allegro defines an extra check for :allocation kinds. AMOP expects any kind to be +;; permissible, though. This is corrected here. + +(defmethod direct-slot-definition-class :before ((class standard-class) &key allocation &allow-other-keys) + (unless (eq (class-of class) (find-class 'standard-class)) + (pushnew allocation (valid-slot-allocations class)))) + +;;; In Allegro, slot-boundp-using-class and slot-makunbound-using-class are specialized +;;; on slot names instead of effective slot definitions. In order to fix this, +;;; we need to rewire the slot access protocol. + +#-(version>= 8 1) +(progn + (cl:defmethod slot-boundp-using-class + ((class standard-class) object (slot symbol)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (let ((slotd (find slot (class-slots class) + :test #'eq + :key #'slot-definition-name))) + (if slotd + (slot-boundp-using-class class object slotd) + (slot-missing class object slot 'slot-boundp)))) + + (cl:defmethod slot-boundp-using-class + ((class standard-class) object (slotd standard-effective-slot-definition)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (slot-boundp-using-class + (load-time-value (class-prototype (find-class 'cl:standard-class))) + object + (slot-definition-name slotd)))) + +(cl:defmethod slot-makunbound-using-class + ((class standard-class) object (slot symbol)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (let ((slotd (find slot (class-slots class) + :test #'eq + :key #'slot-definition-name))) + (if slotd + (slot-makunbound-using-class class object slotd) + (slot-missing class object slot 'slot-makunbound)))) + +(cl:defmethod slot-makunbound-using-class + ((class standard-class) object (slotd standard-effective-slot-definition)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (slot-makunbound-using-class + (load-time-value (class-prototype (find-class 'cl:standard-class))) + object + (slot-definition-name slotd))) + +;; We need a new standard-generic-function for various things. + +(cl:defclass standard-generic-function (cl:standard-generic-function) + () + (:metaclass clos:funcallable-standard-class)) + +;; The following ensures that the new standard-generic-function is used. + +(defun ensure-generic-function + (name &rest args + &key (generic-function-class 'standard-generic-function) + &allow-other-keys) + (declare (dynamic-extent args)) + (when (fboundp name) + (let ((function (fdefinition name))) + (unless (typep function 'generic-function) + (cerror "Discard existing definition and create generic function." + "~S is already fbound, but not as a generic function." name) + (fmakunbound name)))) + (if (fboundp name) + (let ((function (fdefinition name))) + (apply #'ensure-generic-function-using-class + function name args)) + (apply #'ensure-generic-function-using-class nil name + :generic-function-class generic-function-class + args))) + +;; The following macro ensures that the new standard-generic-function +;; is used by default. + +(defmacro defgeneric (name (&rest args) &body options) + (if (member :generic-function-class options :key #'car) + `(cl:defgeneric ,name ,args ,@options) + `(cl:defgeneric ,name ,args ,@options + (:generic-function-class standard-generic-function)))) + +;;; The following three methods ensure that the dependent protocol +;;; for generic function works. + +;; The following method additionally ensures that +;; compute-discriminating-function is triggered. + +(cl:defmethod reinitialize-instance :after + ((gf standard-generic-function) &rest initargs) + (declare (dynamic-extent initargs)) + (set-funcallable-instance-function + gf (compute-discriminating-function gf)) + (map-dependents + gf (lambda (dep) (apply #'update-dependent gf dep initargs)))) + +(cl:defmethod add-method :after + ((gf standard-generic-function) method) + (map-dependents + gf (lambda (dep) (update-dependent gf dep 'add-method method)))) + +(cl:defmethod remove-method :after + ((gf standard-generic-function) method) + (map-dependents + gf (lambda (dep) (update-dependent gf dep 'remove-method method)))) + +(defun ensure-method (gf lambda-expression + &key (qualifiers ()) + (lambda-list (cadr lambda-expression)) + (specializers (required-args lambda-list (constantly (find-class 't))))) + (funcall (compile nil `(lambda () + (defmethod ,(generic-function-name gf) ,@qualifiers + ,(loop for specializer in specializers + for (arg . rest) on lambda-list + collect `(,arg ,specializer) into args + finally (return (nconc args rest))) + ,@(cddr lambda-expression)))))) + +;; The following can be used in direct-slot-definition-class to get the correct initargs +;; for a slot. Use it like this: +;; +;; (defmethod direct-slot-definition-class +;; ((class my-standard-class) &rest initargs) +;; (declare (dynamic-extent initargs)) +;; (destructuring-bind +;; (&key key-of-interest &allow-other-keys) +;; (fix-slot-initargs initargs) +;; ...)) + +(defvar *standard-slot-keys* + '(:name :documentation + :initargs :initform :initfunction + :readers :writers)) + +(defun fix-slot-initargs (initargs) + initargs) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew :closer-mop *features*))

Added: branches/trunk-reorg/thirdparty/closer-mop/clisp/closer-mop-packages.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/clisp/closer-mop-packages.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/clisp/closer-mop-packages.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,183 @@ +(in-package :cl-user) + +(defpackage #:closer-mop + (:use #:common-lisp #:lispworks) + (:nicknames #:c2mop) + + (:import-from #:clos + + #:direct-slot-definition + #:effective-slot-definition + #:eql-specializer + #:forward-referenced-class + #:funcallable-standard-class + #:funcallable-standard-object + #:metaobject + #:slot-definition + #:specializer + #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + + #:accessor-method-slot-definition + #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #:eql-specializer-object + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #:find-method-combination + #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #:intern-eql-specializer + #-clisp #:make-method-lambda + #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #:reader-method-class + #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #:specializer-direct-generic-functions + #:specializer-direct-methods + #:standard-instance-access + #:update-dependent + #:validate-superclass + #:writer-method-class) + + (:export + #:direct-slot-definition + #:effective-slot-definition + #:eql-specializer + #:forward-referenced-class + #:funcallable-standard-class + #:funcallable-standard-object + #:metaobject + #:slot-definition + #:specializer + #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + + #:ensure-finalized + #:ensure-method + #:fix-slot-initargs + #:required-args + + #:accessor-method-slot-definition + #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #:eql-specializer-object + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #:find-method-combination + #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #:intern-eql-specializer + #-clisp #:make-method-lambda + #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #:reader-method-class + #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #:specializer-direct-generic-functions + #:specializer-direct-methods + #:standard-instance-access + #:update-dependent + #:validate-superclass + #:writer-method-class))

Added: branches/trunk-reorg/thirdparty/closer-mop/clisp/closer-mop.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/clisp/closer-mop.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/clisp/closer-mop.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,49 @@ +(in-package :closer-mop) + +;; Some utility functions. + +(defun required-args (lambda-list &optional (collector #'identity)) + (loop for arg in lambda-list + until (member arg lambda-list-keywords) + collect (funcall collector arg))) + +(defun ensure-finalized (class &optional (errorp t)) + (if (typep class 'class) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (when errorp (error "~S is not a class." class))) + class) + +(defun ensure-method (gf lambda-expression + &key (qualifiers ()) + (lambda-list (cadr lambda-expression)) + (specializers (required-args lambda-list (constantly 't)))) + (funcall (compile nil `(lambda () + (defmethod ,(generic-function-name gf) ,@qualifiers + ,(loop for specializer in specializers + for (arg . rest) on lambda-list + collect `(,arg ,specializer) into args + finally (return (nconc args rest))) + ,@(cddr lambda-expression)))))) + +;; The following can be used in direct-slot-definition-class to get the correct initargs +;; for a slot. Use it like this: +;; +;; (defmethod direct-slot-definition-class +;; ((class my-standard-class) &rest initargs) +;; (declare (dynamic-extent initargs)) +;; (destructuring-bind +;; (&key key-of-interest &allow-other-keys) +;; (fix-slot-initargs initargs) +;; ...)) + +(defvar *standard-slot-keys* + '(:name :documentation + :initargs :initform :initfunction + :readers :writers)) + +(defun fix-slot-initargs (initargs) + initargs) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew :closer-mop *features*))

Added: branches/trunk-reorg/thirdparty/closer-mop/closer-mop-utility-packages.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/closer-mop-utility-packages.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/closer-mop-utility-packages.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,18 @@ +(in-package :cl-user) + +(defpackage #:closer-common-lisp + (:nicknames #:c2cl) + (:use)) + +(let ((syms (nunion (loop for sym being the external-symbols of :common-lisp + if (find-symbol (symbol-name sym) :c2mop) + collect it + else collect sym) + (loop for sym being the external-symbols of :c2mop + collect sym)))) + (import syms :c2cl) + (export syms :c2cl)) + +(defpackage #:closer-common-lisp-user + (:nicknames #:c2cl-user) + (:use #:closer-common-lisp))

Added: branches/trunk-reorg/thirdparty/closer-mop/closer-mop.asd =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/closer-mop.asd 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/closer-mop.asd 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,47 @@ +(asdf:defsystem #:closer-mop + :name "Closer to MOP" + :author "Pascal Costanza" + :version "0.42" + :licence " +Copyright (c) 2005 - 2007 Pascal Costanza + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, sublicense, and/or +sell copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. +" + :depends-on (#-lispworks #:lw-compat) + :components + ((:module + #+allegro "allegro" + #+clisp "clisp" + #+ecl "ecl" + #+lispworks "lispworks" + #+(or mcl openmcl) "mcl" + #+(or cmu sbcl) "pcl" + :components ((:file "closer-mop-packages") + (:file "closer-mop" + :depends-on ("closer-mop-packages")))) + (:file "closer-mop-utility-packages" + :depends-on (#+allegro "allegro" + #+clisp "clisp" + #+ecl "ecl" + #+lispworks "lispworks" + #+(or mcl openmcl) "mcl" + #+(or cmu sbcl) "pcl"))))

Added: branches/trunk-reorg/thirdparty/closer-mop/ecl/closer-mop-packages.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/ecl/closer-mop-packages.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/ecl/closer-mop-packages.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,190 @@ +(in-package :cl-user) + +(defpackage #:closer-mop + (:use #:common-lisp #:lispworks) + (:nicknames #:c2mop) + + (:shadow #:defgeneric #:ensure-generic-function #:find-method + #:remove-method #:standard-generic-function) + (:export #:defgeneric #:ensure-generic-function #:find-method + #:remove-method #:standard-generic-function) + + (:import-from #:clos + + #:direct-slot-definition + #:effective-slot-definition + #-ecl #:eql-specializer + #:forward-referenced-class + #-ecl #:funcallable-standard-class + #-ecl #:funcallable-standard-object + #-ecl #:metaobject + #:slot-definition + #-ecl #:specializer + #-ecl #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #-ecl #:standard-reader-method + #:standard-slot-definition + #-ecl #:standard-writer-method + + #-ecl #:accessor-method-slot-definition + #-ecl #:add-dependent + #-ecl #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #-ecl #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #-ecl #:eql-specializer-object + #-ecl #:extract-lambda-list + #-ecl #:extract-specializer-names + #:finalize-inheritance + #-ecl #:find-method-combination + #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #-ecl #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #-ecl #:intern-eql-specializer + #-ecl #:make-method-lambda + #-ecl #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #-ecl #:reader-method-class + #-ecl #:remove-dependent + #-ecl #:remove-direct-method + #:remove-direct-subclass + #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #-ecl #:specializer-direct-generic-functions + #-ecl #:specializer-direct-methods + #:standard-instance-access + #-ecl #:update-dependent + #-ecl #:validate-superclass + #-ecl #:writer-method-class) + + (:export + #:direct-slot-definition + #:effective-slot-definition + #:eql-specializer + #:forward-referenced-class + #-ecl #:funcallable-standard-class + #-ecl #:funcallable-standard-object + #-ecl #:metaobject + #:slot-definition + #-ecl #:specializer + #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + + #:ensure-finalized + #:ensure-method + #:fix-slot-initargs + #:required-args + + #:accessor-method-slot-definition + #-ecl #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #-ecl #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #:eql-specializer-object + #:eql-specializer-object* + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #-ecl #:find-method-combination + #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #-ecl #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #:intern-eql-specializer + #:intern-eql-specializer* + #-ecl #:make-method-lambda + #-ecl #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #:reader-method-class + #-ecl #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #:specializer-direct-generic-functions + #:specializer-direct-methods + #:standard-instance-access + #-ecl #:update-dependent + #-ecl #:validate-superclass + #:writer-method-class))

Added: branches/trunk-reorg/thirdparty/closer-mop/ecl/closer-mop.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/ecl/closer-mop.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/ecl/closer-mop.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,312 @@ +(in-package :closer-mop) + +;; Some utility functions. + +(defun required-args (lambda-list &optional (collector #'identity)) + (loop for arg in lambda-list + until (member arg lambda-list-keywords) + collect (funcall collector arg))) + +(defun ensure-finalized (class &optional (errorp t)) + (if (typep class 'class) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (when errorp (error "~S is not a class." class))) + class) + +(defun extract-lambda-list (lambda-list) + (loop for (arg . rest) on lambda-list + until (member arg lambda-list-keywords) + if (consp arg) + collect (car arg) into args + else collect arg into args + finally (return (if arg + (nconc args (cons arg rest)) + args)))) + +(defun extract-specializer-names (lambda-list) + (loop for arg in lambda-list + until (member arg lambda-list-keywords) + if (consp arg) + collect (cadr arg) + else collect 't)) + +;; We need a new standard-generic-function for various things. + +(cl:defclass standard-generic-function (cl:standard-generic-function) + ()) + +;; The following ensures that the new standard-generic-function is used. + +(defun ensure-generic-function + (name &rest args + &key (generic-function-class 'standard-generic-function) + &allow-other-keys) + (declare (dynamic-extent args)) + (apply #'cl:ensure-generic-function name + :generic-function-class generic-function-class + args)) + +#| +(defun ensure-generic-function + (name &rest args + &key (generic-function-class 'standard-generic-function) + &allow-other-keys) + (declare (dynamic-extent args)) + (when (fboundp name) + (let ((function (fdefinition name))) + (unless (typep function 'generic-function) + (cerror "Discard existing definition and create generic function." + "~S is already fbound, but not as a generic function." name) + (fmakunbound name)))) + (if (fboundp name) + (let ((function (fdefinition name))) + (apply #'ensure-generic-function-using-class + function name args)) + (apply #'ensure-generic-function-using-class nil name + :generic-function-class generic-function-class + args))) +|# + +;; The standard accessor classes. + +(cl:defclass standard-accessor-method (standard-method) + ((slotd :initarg :slot-definition + :reader accessor-method-slot-definition))) + +(cl:defclass standard-reader-method (standard-accessor-method) + ()) + +(cl:defclass standard-writer-method (standard-accessor-method) + ()) + +;; In ECL, reader-method-class and writer-method-class are +;; not used during class initialization. The following definitions +;; correct this. + +(cl:defgeneric reader-method-class (class slot-definition &rest initargs) + (:method ((class class) slot-definition &rest initargs) + (declare (ignore slot-definition initargs)) + (load-time-value (find-class 'standard-reader-method)))) + +(cl:defgeneric writer-method-class (class slot-definition &rest initargs) + (:method ((class class) slot-definition &rest initargs) + (declare (ignore slot-definition initargs)) + (load-time-value (find-class 'standard-writer-method)))) + +(cl:defgeneric find-method (gf qualifiers specializers &optional errorp) + (:method ((gf generic-function) qualifiers specializers &optional (errorp t)) + (cl:find-method gf qualifiers specializers errorp))) + +(defun modify-accessors (class) + (loop with reader-specializers = (list class) + with writer-specializers = (list (find-class 't) class) + for slotd in (class-direct-slots class) do + (loop for reader in (slot-definition-readers slotd) + for reader-function = (fdefinition reader) + for reader-method = (find-method reader-function () reader-specializers) + for initargs = (list :qualifiers () + :lambda-list '(object) + :specializers reader-specializers + :function (method-function reader-method) + :slot-definition slotd) + for method-class = (apply #'reader-method-class class slotd initargs) + unless (eq method-class (class-of reader-method)) + do (add-method reader-function (apply #'make-instance method-class initargs))) + (loop for writer in (slot-definition-writers slotd) + for writer-function = (fdefinition writer) + for writer-method = (find-method writer-function () writer-specializers) + for initargs = (list :qualifiers () + :lambda-list '(new-value object) + :specializers writer-specializers + :function (method-function writer-method) + :slot-definition slotd) + for method-class = (apply #'writer-method-class class slotd initargs) + unless (eq method-class (class-of writer-method)) + do (add-method writer-function (apply #'make-instance method-class initargs))))) + +;; During class re/initialization, we take care of the following things: +;; - Optimization of slot accessors is deactivated. +;; - Removal of direct subclasses. + +(cl:defmethod initialize-instance :around + ((class standard-class) &rest initargs) + (declare (dynamic-extent initargs)) + (prog1 (apply #'call-next-method class + :optimize-slot-access nil + initargs) + (modify-accessors class))) + +(cl:defmethod reinitialize-instance :around + ((class standard-class) &rest initargs + &key (direct-superclasses () direct-superclasses-p)) + (declare (dynamic-extent initargs)) + (when direct-superclasses-p + (loop for superclass in (copy-list (class-direct-superclasses class)) + unless (member superclass direct-superclasses) + do (remove-direct-subclass superclass class))) + (prog1 (apply #'call-next-method class + :optimize-slot-access nil + initargs) + (modify-accessors class))) + +;; In ECL, eql specializers are lists. We cannot change this +;; but we can soften some of the incompatibilities. + +(defun eql-specializer-p (cons) + (and (consp cons) + (eq (car cons) 'eql) + (null (cddr cons)))) + +(deftype eql-specializer () + '(or eql-specializer* + (satisfies eql-specializer-p))) + +(cl:defgeneric eql-specializer-object (eql-specializer) + (:method ((cons cons)) + (if (eql-specializer-p cons) + (cadr cons) + (error "~S is not an eql-specializer." cons)))) + +(defun intern-eql-specializer (object) + `(eql ,object)) + +(cl:defgeneric specializer-direct-methods (specializer)) + +(cl:defclass eql-specializer* (standard-object) + ((obj :reader eql-specializer-object + :initarg eso + :initform (error "Use intern-eql-specializer to create eql-specializers.")) + (direct-methods :reader specializer-direct-methods + :accessor es-direct-methods + :initform ()))) + +(defvar *eql-specializers* (make-hash-table)) + +(defun intern-eql-specializer* (object) + (or (gethash object *eql-specializers*) + (setf (gethash object *eql-specializers*) + (make-instance 'eql-specializer* 'eso object)))) + +(defvar *direct-methods* (make-hash-table :test #'eq)) + +(cl:defgeneric add-direct-method (specializer method) + (:method ((specializer class) (method method)) + (pushnew method (gethash specializer *direct-methods*))) + (:method ((specializer eql-specializer*) (method method)) + (pushnew method (es-direct-methods specializer)))) + +(cl:defgeneric remove-direct-method (specializer method) + (:method ((specializer class) (method method)) + (removef (gethash specializer *direct-methods*) method)) + (:method ((specializer eql-specializer*) (method method)) + (removef (es-direct-methods specializer) method))) + +(cl:defmethod specializer-direct-methods ((class class)) + (gethash class *direct-methods*)) + +(cl:defgeneric specializer-direct-generic-functions (specializer) + (:method ((class class)) + (remove-duplicates + (mapcar #'method-generic-function + (specializer-direct-methods class)))) + (:method ((eql-specializer eql-specializer*)) + (remove-duplicates + (mapcar #'method-generic-function + (specializer-direct-methods eql-specializer)))) + (:method ((cons cons)) + (specializer-direct-generic-functions + (intern-eql-specializer* + (eql-specializer-object cons))))) + +;; The following method ensures that remove-method is called. + +(cl:defmethod add-method :before ((gf standard-generic-function) (method method)) + (when-let (old-method (find-method gf (method-qualifiers method) + (method-specializers method) nil)) + (remove-method gf old-method))) + +;; The following two methods ensure that add/remove-direct-method is called, +;; and that the dependent protocol for generic function works. + +(cl:defmethod add-method :after ((gf standard-generic-function) (method method)) + (loop for specializer in (method-specializers method) + do (add-direct-method + (if (consp specializer) + (intern-eql-specializer* + (eql-specializer-object specializer)) + specializer) + method))) + +(cl:defgeneric remove-method (generic-function method) + (:method ((gf generic-function) (method method)) + (cl:remove-method gf method))) + +(cl:defmethod remove-method :after ((gf generic-function) (method method)) + (loop for specializer in (method-specializers method) + do (remove-direct-method + (if (consp specializer) + (intern-eql-specializer* + (eql-specializer-object specializer)) + specializer) + method))) + +(defun ensure-method (gf lambda-expression + &key (qualifiers ()) + (lambda-list (cadr lambda-expression)) + (specializers (required-args lambda-list (constantly (find-class 't))))) + (funcall (compile nil `(lambda () + (defmethod ,(generic-function-name gf) ,@qualifiers + ,(loop for specializer in specializers + for (arg . rest) on lambda-list + collect `(,arg ,specializer) into args + finally (return (nconc args rest))) + ,@(cddr lambda-expression)))))) + +(defmacro defgeneric (&whole form name (&rest args) &body options) + (unless (every #'consp options) + (error "Illegal generic functions options in defgeneric form ~S." form)) + `(cl:defgeneric ,name ,args + ,@options + ,@(unless (member :generic-function-class options :key #'car :test #'eq) + '((:generic-function-class standard-generic-function))))) + +;; The following can be used in direct-slot-definition-class to get the correct initargs +;; for a slot. Use it like this: +;; +;; (defmethod direct-slot-definition-class +;; ((class my-standard-class) &rest initargs) +;; (declare (dynamic-extent initargs)) +;; (destructuring-bind +;; (&key key-of-interest &allow-other-keys) +;; (fix-slot-initargs initargs) +;; ...)) + +(defvar *standard-slot-keys* + '(:name :documentation + :initargs :initform :initfunction + :readers :writers)) + +(defun fix-slot-initargs (initargs) + (let* ((counts (loop with counts + for (key nil) on initargs by #'cddr + do (incf (getf counts key 0)) + finally (return counts))) + (keys-to-fix (loop for (key value) on counts by #'cddr + if (> value 1) collect key))) + (if keys-to-fix + (let ((multiple-standard-keys + (intersection keys-to-fix *standard-slot-keys*))) + (if multiple-standard-keys + (error "Too many occurences of ~S in slot initargs ~S." + multiple-standard-keys initargs) + (loop with fixed-keys + for (key value) on initargs by #'cddr + if (member key keys-to-fix) + do (nconcf (getf fixed-keys key) (list value)) + else nconc (list key value) into fixed-initargs + finally (return (nconc fixed-initargs fixed-keys))))) + initargs))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew :closer-mop *features*))

Added: branches/trunk-reorg/thirdparty/closer-mop/features.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/features.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/features.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,498 @@ + +:allegro7.0 +((:class-default-initargs) + (:class-direct-default-initargs) + (:compute-default-initargs) ; -> :compute-default-initargs-allegro + (:default-superclass-for-funcallable-standard-class-is-funcallable-standard-object) + (:defgeneric-calls-find-method-combination) + (:defmethod-calls-make-method-lambda) + (:dependent-protocol-for-generic-functions fixed) + (:extensible-allocation fixed) + (:function-invocation-calls-compute-applicable-methods) + (:function-invocation-calls-compute-applicable-methods-using-classes) + (:function-invocation-calls-compute-effective-method) + (:make-method-lambda) + (:method-functions-take-processed-parameters) + (:method-lambdas-are-processed) + (:multiple-qualifiers) + (:reinitialize-instance-calls-compute-discriminating-function fixed) + (:setf-class-name-calls-reinitialize-instance) + (:setf-generic-function-name-calls-reinitialize-instance) + (:slot-boundp-using-class-specialized-on-slot-definition fixed) + (:slot-makunbound-using-class-specialized-on-slot-definition fixed) + (:standard-class-and-funcallable-standard-class-are-compatible) + (:subclasses-of-built-in-class-do-not-inherit-exported-slots) + (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots) + (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots) + (:subclasses-of-method-combination-do-not-inherit-exported-slots) + (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-class-do-not-inherit-exported-slots) + (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) + (:subclasses-of-standard-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots) + (:t-is-always-a-valid-superclass)) + +:allegro8.0 +((:class-default-initargs) + (:class-direct-default-initargs) + (:compute-default-initargs) ; -> :compute-default-initargs-allegro + (:default-superclass-for-funcallable-standard-class-is-funcallable-standard-object) + (:defgeneric-calls-find-method-combination) + (:defmethod-calls-make-method-lambda) + (:dependent-protocol-for-generic-functions fixed) + (:extensible-allocation fixed) + (:function-invocation-calls-compute-applicable-methods) + (:function-invocation-calls-compute-applicable-methods-using-classes) + (:function-invocation-calls-compute-effective-method) + (:make-method-lambda) + (:method-functions-take-processed-parameters) + (:method-lambdas-are-processed) + (:reinitialize-instance-calls-compute-discriminating-function fixed) + (:setf-class-name-calls-reinitialize-instance) + (:setf-generic-function-name-calls-reinitialize-instance) + (:slot-boundp-using-class-specialized-on-slot-definition fixed) + (:slot-makunbound-using-class-specialized-on-slot-definition fixed) + (:standard-class-and-funcallable-standard-class-are-compatible) + (:subclasses-of-built-in-class-do-not-inherit-exported-slots) + (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots) + (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots) + (:subclasses-of-method-combination-do-not-inherit-exported-slots) + (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-class-do-not-inherit-exported-slots) + (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) + (:subclasses-of-standard-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots) + (:t-is-always-a-valid-superclass)) + +:allegro8.1 +((:class-default-initargs) + (:class-direct-default-initargs) + (:compute-default-initargs) ; -> :compute-default-initargs-allegro + (:default-superclass-for-funcallable-standard-class-is-funcallable-standard-object) + (:defgeneric-calls-find-method-combination) + (:defmethod-calls-make-method-lambda) + (:dependent-protocol-for-generic-functions fixed) + (:extensible-allocation fixed) + (:function-invocation-calls-compute-applicable-methods) + (:function-invocation-calls-compute-applicable-methods-using-classes) + (:function-invocation-calls-compute-effective-method) + (:make-method-lambda) + (:method-functions-take-processed-parameters) + (:method-lambdas-are-processed) + (:reinitialize-instance-calls-compute-discriminating-function fixed) + (:setf-class-name-calls-reinitialize-instance) + (:setf-generic-function-name-calls-reinitialize-instance) + (:slot-makunbound-using-class-specialized-on-slot-definition fixed) + (:standard-class-and-funcallable-standard-class-are-compatible) + (:subclasses-of-built-in-class-do-not-inherit-exported-slots) + (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots) + (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots) + (:subclasses-of-method-combination-do-not-inherit-exported-slots) + (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-class-do-not-inherit-exported-slots) + (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) + (:subclasses-of-standard-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots) + (:t-is-always-a-valid-superclass)) + +:clisp2.35-2.36 +((:accessor-method-initialized-with-function) + (:add-method-calls-compute-discriminating-function) + (:compute-slots-requested-slot-order-honoured) + (:defmethod-calls-make-method-lambda) + (:extensible-allocation) + (:forward-referenced-class-changed-by-change-class) + (:initialize-instance-calls-compute-discriminating-function) + (:make-method-lambda) + (:method-initialized-with-function) + (:method-lambdas-are-processed) + (:reinitialize-instance-calls-compute-discriminating-function) + (:reinitialize-instance-calls-finalize-inheritance) + (:remove-method-calls-compute-discriminating-function) + (:subclasses-of-method-combination-do-not-inherit-exported-slots)) + +:clisp2.37-2.39 +((:accessor-method-initialized-with-function) + (:add-method-calls-compute-discriminating-function) + (:compute-slots-requested-slot-order-honoured) + (:defmethod-calls-make-method-lambda) + (:forward-referenced-class-changed-by-change-class) + (:initialize-instance-calls-compute-discriminating-function) + (:make-method-lambda) + (:method-initialized-with-function) + (:method-lambdas-are-processed) + (:reinitialize-instance-calls-compute-discriminating-function) + (:reinitialize-instance-calls-finalize-inheritance) + (:remove-method-calls-compute-discriminating-function) + (:subclasses-of-method-combination-do-not-inherit-exported-slots)) + +:clisp2.40-2.41 +((:accessor-method-initialized-with-function) + (:add-method-calls-compute-discriminating-function) + (:compute-slots-requested-slot-order-honoured) + (:defmethod-calls-make-method-lambda) + (:forward-referenced-class-changed-by-change-class) + (:initialize-instance-calls-compute-discriminating-function) + (:make-method-lambda) + (:method-initialized-with-function) + (:method-lambdas-are-processed) + (:reinitialize-instance-calls-compute-discriminating-function) + (:remove-method-calls-compute-discriminating-function) + (:subclasses-of-method-combination-do-not-inherit-exported-slots)) + +:cmu19c-19d +((:accessor-method-initialized-with-function fixed) + (:accessor-method-initialized-with-lambda-list fixed) + (:accessor-method-initialized-with-slot-definition fixed) + (:accessor-method-initialized-with-specializers fixed) + (:anonymous-classes fixed) + (:class-default-initargs) + (:class-direct-default-initargs) + (:class-initialization-calls-reader-method-class fixed) + (:class-initialization-calls-writer-method-class fixed) + (:discriminating-functions-can-be-closures) + (:discriminating-functions-can-be-funcalled) + (:documentation-passed-to-effective-slot-definition-class) + (:effective-slot-definition-initialized-with-documentation) + (:method-initialized-with-function) + (:multiple-slot-options-passed-as-list-to-direct-slot-definition-class) ; fix with fix-slot-initargs + (:reinitialize-instance-calls-compute-discriminating-function fixed) + (:reinitialize-instance-calls-finalize-inheritance) + (:setf-class-name-calls-reinitialize-instance) + (:setf-generic-function-name-calls-reinitialize-instance) + (:slot-definition-documentation fixed) + (:standard-class-and-funcallable-standard-class-are-compatible) + (:subclasses-of-built-in-class-do-not-inherit-exported-slots) + (:subclasses-of-class-do-not-inherit-exported-slots) + (:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-eql-specializer-do-not-inherit-exported-slots) + (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots) + (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots) + (:subclasses-of-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-specializer-do-not-inherit-exported-slots) + (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-class-do-not-inherit-exported-slots) + (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) + (:subclasses-of-standard-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots)) + +:ecl0.9i +((:accessor-method-initialized-with-function fixed) + (:accessor-method-initialized-with-lambda-list fixed) + (:accessor-method-initialized-with-slot-definition fixed) + (:accessor-method-initialized-with-specializers fixed) + (:accessor-method-slot-definition fixed) + (:add-direct-method fixed) + (:add-method-calls-add-direct-method fixed) + (:add-method-calls-compute-discriminating-function) + (:add-method-calls-remove-method fixed) + (:add-method-updates-specializer-direct-generic-functions fixed) + (:add-method-updates-specializer-direct-methods fixed) + (:class-default-initargs) + (:class-direct-default-initargs) + (:class-initialization-calls-reader-method-class fixed) + (:class-initialization-calls-writer-method-class fixed) + (:class-reinitialization-calls-remove-direct-subclass fixed) + (:classes-are-always-their-own-valid-superclasses) + (:compute-applicable-methods-is-generic) + (:compute-applicable-methods-using-classes) + (:compute-effective-method-is-generic) + (:default-superclass-for-funcallable-standard-class-is-funcallable-standard-object) + (:default-reader-methods-are-standard-reader-methods fixed) + (:default-writer-methods-are-standard-writer-methods fixed) + (:defgeneric-calls-find-method-combination) + (:defmethod-calls-generic-function-method-class) + (:defmethod-calls-initialize-instance) + (:defmethod-calls-make-method-lambda) + (:dependent-protocol-for-classes) + (:dependent-protocol-for-generic-functions) + (:direct-slot-definition-initialized-with-type) + (:discriminating-functions-can-be-closures) + (:discriminating-functions-can-be-funcalled) + (:eql-specializer) + (:eql-specializer-object fixed) + (:eql-specializers-are-objects) + (:extract-lambda-list fixed) + (:extract-specializer-names fixed) + (:find-method-combination) + (:find-method-is-generic fixed) + (:funcallable-standard-class) + (:funcallable-standard-object) + (:function-invocation-calls-compute-applicable-methods) + (:function-invocation-calls-compute-applicable-methods-using-classes) + (:function-invocation-calls-compute-effective-method) + (:generic-function-declarations) + (:generic-function-method-class-is-generic) + (:generic-function-method-combination) + (:generic-functions-can-be-empty) + (:initform-passed-to-direct-slot-definition-class) + (:initform-passed-to-effective-slot-definition-class) + (:initialize-instance-calls-compute-discriminating-function) + (:intern-eql-specializer fixed) + (:make-method-lambda) + (:metaobject) + (:method-functions-take-processed-parameters) + (:method-initialized-with-documentation) + (:method-initialized-with-function) + (:method-initialized-with-lambda-list) + (:method-initialized-with-qualifiers) + (:method-initialized-with-specializers) + (:method-lambdas-are-processed) + (:multiple-slot-options-passed-as-list-to-direct-slot-definition-class) + (:reader-method-class fixed) + (:reinitialize-instance-calls-compute-discriminating-function) + (:remove-direct-method fixed) + (:remove-method-calls-compute-discriminating-function) + (:remove-method-calls-remove-direct-method fixed) + (:remove-method-is-generic fixed) + (:setf-class-name-calls-reinitialize-instance) + (:setf-generic-function-name) + (:setf-generic-function-name-calls-reinitialize-instance) + (:slot-definition-documentation) + (:slot-definition-initform) + (:slot-definition-initfunction) + (:slot-definition-type) + (:slot-reader-calls-slot-value-using-class fixed) + (:slot-writer-calls-slot-value-using-class fixed) + (:specializer) + (:specializer-direct-generic-functions fixed) + (:specializer-direct-methods fixed) + (:standard-accessor-method fixed) + (:standard-class-and-funcallable-standard-class-are-compatible) + (:standard-reader-method fixed) + (:standard-writer-method fixed) + (:subclasses-of-built-in-class-do-not-inherit-exported-slots) + (:subclasses-of-class-do-not-inherit-exported-slots) + (:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots) + (:subclasses-of-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-class-do-not-inherit-exported-slots) + (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) + (:subclasses-of-standard-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) + (:t-is-always-a-valid-superclass) + (:type-passed-to-direct-slot-definition-class) + (:validate-superclass) + (:writer-method-class fixed)) + +:lispworks4.4 +((:add-method-calls-add-direct-method fixed) + (:add-method-calls-compute-discriminating-function) + (:add-method-calls-remove-method fixed) + (:add-method-updates-specializer-direct-generic-functions fixed) + (:allocation-passed-to-effective-slot-definition-class) ; instead :flags-passed-to-effective-slot-definition-class + (:class-default-initargs) + (:class-direct-default-initargs) + (:class-initialized-with-direct-default-initargs) ; instead: conditionalization + (:class-reinitialization-calls-remove-direct-subclass fixed) + (:compute-applicable-methods-using-classes) + (:compute-default-initargs) + (:defgeneric-calls-find-method-combination) + (:direct-superclasses-by-default-empty) ; not fixed, but direct superclasses are automatically adjusted + (:effective-slot-definition-initialized-with-allocation) ; instead :effective-slot-definition-initialized-with-flags + (:eql-specializer) ; partially fixed + (:eql-specializer-object fixed) + (:eql-specializers-are-objects) + (:extensible-allocation) + (:finalize-inheritance-calls-compute-default-initargs) + (:find-method-combination fixed) ; partially + (:funcallable-standard-instance-access) + (:function-invocation-calls-compute-applicable-methods) + (:function-invocation-calls-compute-applicable-methods-using-classes) + (:generic-function-initialized-with-declarations) ; map from generic-function-initialized-with-declare + (:initialize-instance-calls-compute-discriminating-function) + (:intern-eql-specializer fixed) ; partially + (:make-method-lambda fixed) ; partially + (:method-functions-take-processed-parameters) + (:reinitialize-instance-calls-compute-discriminating-function) + (:remove-method-calls-compute-discriminating-function) + (:remove-method-calls-remove-direct-method fixed) + (:setf-class-name-calls-reinitialize-instance) + (:setf-generic-function-name-calls-reinitialize-instance) + (:setf-slot-value-using-class-specialized-on-slot-definition fixed) + (:slot-boundp-using-class-specialized-on-slot-definition fixed) + (:slot-makunbound-using-class-specialized-on-slot-definition fixed) + (:slot-reader-calls-slot-value-using-class fixed) + (:slot-value-using-class-specialized-on-slot-definition fixed) + (:slot-writer-calls-slot-value-using-class fixed) + (:specializer) + (:specializer-direct-generic-functions fixed) + (:standard-class-and-funcallable-standard-class-are-compatible) + (:standard-instance-access) + (:subclasses-of-built-in-class-do-not-inherit-exported-slots fixed) + (:subclasses-of-class-do-not-inherit-exported-slots fixed) + (:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots fixed) + (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots fixed) + (:subclasses-of-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-class-do-not-inherit-exported-slots fixed) + (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) + (:subclasses-of-standard-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots)) + +:lispworks5.0-5.0.2 +((:add-method-calls-compute-discriminating-function) + (:add-method-updates-specializer-direct-generic-functions fixed) + (:class-default-initargs) + (:class-direct-default-initargs) + (:compute-applicable-methods-using-classes) + (:compute-default-initargs) + (:defgeneric-calls-find-method-combination) + (:eql-specializer) ; partially fixed + (:eql-specializer-object fixed) + (:eql-specializers-are-objects) + (:extensible-allocation) + (:finalize-inheritance-calls-compute-default-initargs) + (:find-method-combination fixed) ; partially + (:funcallable-standard-instance-access) + (:function-invocation-calls-compute-applicable-methods) + (:function-invocation-calls-compute-applicable-methods-using-classes) + (:initialize-instance-calls-compute-discriminating-function) + (:intern-eql-specializer fixed) ; partially + (:make-method-lambda fixed) ; partially + (:method-functions-take-processed-parameters) + (:reinitialize-instance-calls-compute-discriminating-function) + (:remove-method-calls-compute-discriminating-function) + (:setf-slot-value-using-class-specialized-on-slot-definition fixed) + (:slot-boundp-using-class-specialized-on-slot-definition fixed) + (:slot-makunbound-using-class-specialized-on-slot-definition fixed) + (:slot-reader-calls-slot-value-using-class fixed) + (:slot-value-using-class-specialized-on-slot-definition fixed) + (:slot-writer-calls-slot-value-using-class fixed) + (:specializer) + (:specializer-direct-generic-functions fixed) + (:standard-class-and-funcallable-standard-class-are-compatible) + (:standard-instance-access) + (:subclasses-of-built-in-class-do-not-inherit-exported-slots fixed) + (:subclasses-of-class-do-not-inherit-exported-slots fixed) + (:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots fixed) + (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots fixed) + (:subclasses-of-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-class-do-not-inherit-exported-slots fixed) + (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) + (:subclasses-of-standard-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots)) + +:mcl +((:add-method-calls-compute-discriminating-function) + (:compute-applicable-methods-using-classes) + (:default-superclass-for-funcallable-standard-class-is-funcallable-standard-object) + (:defmethod-calls-generic-function-method-class) + (:defmethod-calls-make-method-lambda) + (:discriminating-functions-can-be-closures) + (:discriminating-functions-can-be-funcalled) + (:funcallable-standard-object) + (:function-invocation-calls-compute-applicable-methods) + (:function-invocation-calls-compute-applicable-methods-using-classes) + (:function-invocation-calls-compute-effective-method) + (:generic-function-declarations) + (:generic-function-initialized-with-declarations) + (:generic-functions-can-be-empty) + (:initialize-instance-calls-compute-discriminating-function) + (:make-method-lambda) + (:method-functions-take-processed-parameters) + (:method-lambdas-are-processed) + (:reinitialize-instance-calls-compute-discriminating-function) + (:reinitialize-lambda-list-reinitializes-argument-precedence-order) + (:remove-method-calls-compute-discriminating-function) + (:set-funcallable-instance-function) + (:setf-generic-function-name) + (:setf-generic-function-name-calls-reinitialize-instance) +; --- + (:compute-slots-requested-slot-order-honoured) + (:direct-slot-definition fixed) + (:direct-superclasses-by-default-empty) ; not fixed, but direct superclasses are automatically adjusted, not for funcallable-standard-class though + (:effective-slot-definition fixed) + (:eql-specializer fixed) + (:extensible-allocation) + (:multiple-slot-options-passed-as-list-to-direct-slot-definition-class) ; fix with fix-slot-initargs + (:reinitialize-instance-calls-finalize-inheritance) + (:setf-class-name-calls-reinitialize-instance) + (:slot-definition fixed) + (:standard-slot-definition fixed) + (:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) + (:subclasses-of-standard-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots)) + +:openmcl +((:add-method-calls-compute-discriminating-function) + (:compute-applicable-methods-using-classes) + (:default-superclass-for-funcallable-standard-class-is-funcallable-standard-object) + (:defmethod-calls-generic-function-method-class) + (:defmethod-calls-make-method-lambda) + (:discriminating-functions-can-be-closures) + (:discriminating-functions-can-be-funcalled) + (:funcallable-standard-object) + (:function-invocation-calls-compute-applicable-methods) + (:function-invocation-calls-compute-applicable-methods-using-classes) + (:function-invocation-calls-compute-effective-method) + (:generic-functions-can-be-empty) + (:initialize-instance-calls-compute-discriminating-function) + (:make-method-lambda) + (:method-functions-take-processed-parameters) + (:method-lambdas-are-processed) + (:reinitialize-instance-calls-compute-discriminating-function) + (:reinitialize-lambda-list-reinitializes-argument-precedence-order) + (:remove-method-calls-compute-discriminating-function) +; --- + (:compute-slots-requested-slot-order-honoured) + (:eql-specializer fixed) + (:reinitialize-instance-calls-finalize-inheritance) + (:slot-definition-documentation fixed) + (:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-generic-function-do-not-inherit-exported-slots) + (:subclasses-of-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slot) + (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) + (:subclasses-of-standard-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) + (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) + (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots)) + +:sbcl 0.9.16-1.0.10 +#| all features implemented |#

Added: branches/trunk-reorg/thirdparty/closer-mop/features.txt =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/features.txt 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/features.txt 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,225 @@ +Features that don't adhere to AMOP in various CLOS MOP implementations, and whether and how they are resolved in Closer to MOP. + +Allegro Common Lisp 7.0 + +- CLASS-DIRECT-DEFAULT-INITARGS and CLASS-DEFAULT-INITARGS don't return canonicalized default initargs as specified. Not fixed. +- COMPUTE-DEFAULT-INITARGS takes more parameters than specified. Not fixed. Conditionalize on #+allegro for your own methods instead. +- FUNCALLABLE-STANDARD-OBJECT is not used as the default superclass for classes with :metaclass FUNCALLABLE-STANDARD-CLASS. +- DEFGENERIC does not call FIND-METHOD-COMBINATION. Not fixed. +- DEFMETHOD doesn't call MAKE-METHOD-LAMBDA. Not fixed. +- The dependent protocol for generic functions doesn't work fully. Fixed. +- The function invocation protocol doesn't call COMPUTE-APPLICABLE-METHODS, COMPUTE-APPLICABLE-METHODS-USING-CLASSES and COMPUTE-EFFECTIVE-METHOD. Not fixed. +- The :ALLOCATION type cannot be extended. Fixed. +- MAKE-METHOD-LAMBDA is not provided. Not fixed. +- Method functions don't take parameters as specified in AMOP, but instead just the parameters that the generic function receives. Not fixed. +- The defmethod form does not accept multiple qualifiers. Not fixed. +- REINITIALIZE-INSTANCE doesn't determine a new discriminating function. Fixed. +- (SETF CLASS-NAME) and (SETF GENERIC-FUNCTION-NAME) do not use REINITIALIZE-INSTANCE for changing the names. Not fixed. +- SLOT-BOUNDP-USING-CLASS and SLOT-MAKUNBOUND-USING-CLASS are not specialized on slot definition metaobjects, but on symbols. Fixed. +- STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. Not fixed. +- VALIDATE-SUPERCLASS doesn't recognize T as a valid superclass. Not fixed. +- Subclasses of BUILT-IN-CLASS, FORWARD-REFERENCED-CLASS, FUNCALLABLE-STANDARD-CLASS, METHOD-COMBINATION, STANDARD-ACCESSOR-METHOD, STANDARD-CLASS, STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. + +Allegro Common Lisp 8.0 + +- CLASS-DIRECT-DEFAULT-INITARGS and CLASS-DEFAULT-INITARGS don't return canonicalized default initargs as specified. Not fixed. +- COMPUTE-DEFAULT-INITARGS takes more parameters than specified. Not fixed. Conditionalize on #+allegro for your own methods instead. +- FUNCALLABLE-STANDARD-OBJECT is not used as the default superclass for classes with :metaclass FUNCALLABLE-STANDARD-CLASS. +- DEFGENERIC does not call FIND-METHOD-COMBINATION. Not fixed. +- DEFMETHOD doesn't call MAKE-METHOD-LAMBDA. Not fixed. +- The dependent protocol for generic functions doesn't work fully. Fixed. +- The function invocation protocol doesn't call COMPUTE-APPLICABLE-METHODS, COMPUTE-APPLICABLE-METHODS-USING-CLASSES and COMPUTE-EFFECTIVE-METHOD. Not fixed. +- The :ALLOCATION type cannot be extended. Fixed. +- MAKE-METHOD-LAMBDA is not provided. Not fixed. +- Method functions don't take parameters as specified in AMOP, but instead just the parameters that the generic function receives. Not fixed. +- REINITIALIZE-INSTANCE doesn't determine a new discriminating function. Fixed. +- (SETF CLASS-NAME) and (SETF GENERIC-FUNCTION-NAME) do not use REINITIALIZE-INSTANCE for changing the names. Not fixed. +- SLOT-BOUNDP-USING-CLASS and SLOT-MAKUNBOUND-USING-CLASS are not specialized on slot definition metaobjects, but on symbols. Fixed. +- STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. Not fixed. +- VALIDATE-SUPERCLASS doesn't recognize T as a valid superclass. Not fixed. +- Subclasses of BUILT-IN-CLASS, FORWARD-REFERENCED-CLASS, FUNCALLABLE-STANDARD-CLASS, METHOD-COMBINATION, STANDARD-ACCESSOR-METHOD, STANDARD-CLASS, STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. + +Allegro Common Lisp 8.1 + +- CLASS-DIRECT-DEFAULT-INITARGS and CLASS-DEFAULT-INITARGS don't return canonicalized default initargs as specified. Not fixed. +- COMPUTE-DEFAULT-INITARGS takes more parameters than specified. Not fixed. Conditionalize on #+allegro for your own methods instead. +- FUNCALLABLE-STANDARD-OBJECT is not used as the default superclass for classes with :metaclass FUNCALLABLE-STANDARD-CLASS. +- DEFGENERIC does not call FIND-METHOD-COMBINATION. Not fixed. +- DEFMETHOD doesn't call MAKE-METHOD-LAMBDA. Not fixed. +- The dependent protocol for generic functions doesn't work fully. Fixed. +- The function invocation protocol doesn't call COMPUTE-APPLICABLE-METHODS, COMPUTE-APPLICABLE-METHODS-USING-CLASSES and COMPUTE-EFFECTIVE-METHOD. Not fixed. +- The :ALLOCATION type cannot be extended. Fixed. +- MAKE-METHOD-LAMBDA is not provided. Not fixed. +- Method functions don't take parameters as specified in AMOP, but instead just the parameters that the generic function receives. Not fixed. +- REINITIALIZE-INSTANCE doesn't determine a new discriminating function. Fixed. +- (SETF CLASS-NAME) and (SETF GENERIC-FUNCTION-NAME) do not use REINITIALIZE-INSTANCE for changing the names. Not fixed. +- SLOT-MAKUNBOUND-USING-CLASS is not specialized on slot definition metaobjects, but on symbols. Fixed. +- STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. Not fixed. +- VALIDATE-SUPERCLASS doesn't recognize T as a valid superclass. Not fixed. +- Subclasses of BUILT-IN-CLASS, FORWARD-REFERENCED-CLASS, FUNCALLABLE-STANDARD-CLASS, METHOD-COMBINATION, STANDARD-ACCESSOR-METHOD, STANDARD-CLASS, STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. + +CLisp 2.35 and 2.36 + +None of the incompatibilities in CLisp are fixed. + +- Methods are not initialized with :function. +- ADD-METHOD, REMOVE-METHOD, INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE do not determine a new discriminating function. This is postponed until function invocation instead, so shouldn't be a problem in practice. +- The slot order requested by a primary method for COMPUTE-SLOTS is not honoured by this MOP. +- DEFMETHOD does not call MAKE-METHOD-LAMBDA. +- The :ALLOCATION type cannot be extended. Not fixed. +- A FORWARD-REFERENCED-CLASS is not changed via CHANGE-CLASS (but is correctly reinitialized via REINITIALIZE-INSTANCE). +- MAKE-METHOD-LAMBDA is not provided. +- REINITIALIZE-INSTANCE of a class metaobject doesn't invoke FINALIZE-INHERITANCE again. Not fixed. +- Subclasses of METHOD-COMBINATION will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. + +CLisp 2.37 - 2.39 + +None of the incompatibilities in CLisp are fixed. + +- Methods are not initialized with :function. +- ADD-METHOD, REMOVE-METHOD, INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE do not determine a new discriminating function. This is postponed until function invocation instead, so shouldn't be a problem in practice. +- The slot order requested by a primary method for COMPUTE-SLOTS is not honoured by this MOP. +- DEFMETHOD does not call MAKE-METHOD-LAMBDA. +- A FORWARD-REFERENCED-CLASS is not changed via CHANGE-CLASS (but is correctly reinitialized via REINITIALIZE-INSTANCE). +- MAKE-METHOD-LAMBDA is not provided. +- REINITIALIZE-INSTANCE of a class metaobject doesn't invoke FINALIZE-INHERITANCE again. Not fixed. +- Subclasses of METHOD-COMBINATION will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. + +CLisp 2.40 and 2.41 + +None of the incompatibilities in CLisp are fixed. + +- Methods are not initialized with :function. +- ADD-METHOD, REMOVE-METHOD, INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE do not determine a new discriminating function. This is postponed until function invocation instead, so shouldn't be a problem in practice. +- The slot order requested by a primary method for COMPUTE-SLOTS is not honoured by this MOP. +- DEFMETHOD does not call MAKE-METHOD-LAMBDA. +- A FORWARD-REFERENCED-CLASS is not changed via CHANGE-CLASS (but is correctly reinitialized via REINITIALIZE-INSTANCE). +- MAKE-METHOD-LAMBDA is not provided. +- Subclasses of METHOD-COMBINATION will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. + +CMUCL 19c, 19d + +- CLASS-DIRECT-DEFAULT-INITARGS and CLASS-DEFAULT-INITARGS don't return canonicalized default initargs as specified. Not fixed. +- Accessor methods are not initialized with :function, :lambda-list, :slot-definition and :specializers. Fixed. +- Classes cannot be anonymous. Fixed. +- Class initialization doesn't call READER-METHOD-CLASS and WRITER-METHOD-CLASS for accessor methods. Fixed. +- The object returned by compute-discriminating-function cannot be a closure. Likewise, the second parameter to set-funcallable-instance-function cannot be a closure, but only a "pure" function/thunk. Not fixed. +- Effective slot definitions are not initialized with :documentation, and EFFECTIVE-SLOT-DEFINITION-CLASS also doesn't receive that initarg. Not fixed. +- Calling DOCUMENTATION on effective slot definition metaobjects don't return their documentation as specified in ANSI Common Lisp. Fixed. +- Methods are not initialized with :function. Not fixed. +- Multiple slot options are not passed as lists to DIRECT-SLOT-DEFINITION-CLASS. Not fixed, but use FIX-SLOT-INITARGS as a workaround. +- REINITIALIZE-INSTANCE doesn't determine a new discriminating function. Fixed. +- REINITIALIZE-INSTANCE of a class metaobject doesn't invoke FINALIZE-INHERITANCE again. Not fixed. +- (SETF CLASS-NAME) and (SETF GENERIC-FUNCTION-NAME) do not use REINITIALIZE-INSTANCE for changing the names. Fixed. +- STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. Not fixed. +- Subclasses of BUILT-IN-CLASS, CLASS, DIRECT-SLOT-DEFINITION, EFFECTIVE-SLOT-DEFINITION, EQL-SPECIALIZER, FORWARD-REFERENCED-CLASS, FUNCALLABLE-STANDARD-CLASS, SLOT-DEFINITION, SPECIALIZER, STANDARD-ACCESSOR-METHOD, STANDARD-CLASS, STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. + +LispWorks, 4.4.5, 4.4.6, Personal and Professional Editions + +- CLASS-DIRECT-DEFAULT-INITARGS and CLASS-DEFAULT-INITARGS don't return canonicalized default initargs as specified. Not fixed. +- ADD-METHOD doesn't call ADD-DIRECT-METHOD and REMOVE-METHOD. Fixed. +- ADD-METHOD, REMOVE-METHOD, INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE do not determine a new discriminating function. This is postponed until function invocation instead, so shouldn't be a problem in practice. +- Effective slot definitions are not initialized with :allocation, and EFFECTIVE-SLOT-DEFINITION-CLASS also doesn't receive that initarg. Not fixed. This information is encoded in the initarg :flags, but I don't have any detailed information about that parameter. +- Classes are not initialized with :direct-default-initargs, but with :default-initargs. Conditionalize on #+lispworks to fix this. +- Class reinitialization does not call REMOVE-DIRECT-SUBCLASS. Fixed. +- COMPUTE-APPLICABLE-METHODS-USING-CLASSES doesn't exist. Not fixed. +- COMPUTE-DEFAULT-INITARGS doesn't exist. Not fixed. +- DEFGENERIC does not call FIND-METHOD-COMBINATION. Not fixed. +- When classes are initialized, :direct-superclasses are by default not empty. Not fixed, but direct superclasses are automatically adjusted when you use the standard idiom for adding a new default superclass. +- EQL-SPECIALIZER, EQL-SPECIALIZER-OBJECT and INTERN-EQL-SPECIALIZER don't exist. In LispWorks, eql specializers are lists not objects. I have provided EQL-SPECIALIZER as a type (not as a class) and EQL-SPECIALIZER-OBJECT and INTERN-EQL-SPECIALIZER to work on lists, and a class EQL-SPECIALIZER* and corresponding EQL-SPECIALIZER-OBJECT* and INTERN-EQL-SPECILAIZER* to soften the incompatibilities. +- The :ALLOCATION type cannot be extended. Not fixed. +- FIND-METHOD-COMBINATION doesn't exist. Fixed, but fixed version doesn't work with method combination options. +- FUNCALLABLE-STANDARD-INSTANCE-ACCESS and STANDARD-INSTANCE-ACCESS don't exist. Not fixed. +- The function invocation protocol doesn't call COMPUTE-APPLICABLE-METHODS and COMPUTE-APPLICABLE-METHODS-USING-CLASSES. Not fixed. +- Generic functions are not initialized with :declarations, but with 'declare. Not fixed. Conditionalize on #+lispworks instead. +- MAKE-METHOD-LAMBDA expects other parameters than specified. Fixed. +- Method functions don't take parameters as specified in AMOP, but instead just the parameters that the generic function receives. Not fixed. +- REMOVE-METHOD doesn't call REMOVE-DIRECT-METHOD. Fixed. +- (SETF CLASS-NAME) and (SETF GENERIC-FUNCTION-NAME) do not use REINITIALIZE-INSTANCE for changing the names. Not fixed. +- The slot methods (SLOT-VALUE-USING-CLASS, etc.) are not specialized on effective slot definitions, but on slot names. Fixed. +- The generated accessor methods don't use the slot methods for accessing slots. Fixed. (Don't use :optimize-slot-access to deoptimize slot access, or otherwise the fixed slot access protocol doesn't work anymore!) +- SPECIALIZER doesn't exist. Not fixed. +- SPECIALIZER-DIRECT-GENERIC-FUNCTIONS doesn't exist. Fixed. +- STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. Not fixed. +- Subclasses of BUILT-IN-CLASS (fixed), CLASS (fixed), DIRECT-SLOT-DEFINITION, EFFECTIVE-SLOT-DEFINITION, FORWARD-REFERENCED-CLASS (fixed), FUNCALLABLE-STANDARD-CLASS (fixed), SLOT-DEFINITION, STANDARD-ACCESSOR-METHOD, STANDARD-CLASS (fixed), STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed, except where indicated otherwise. + + +LispWorks, 5.0 and 5.0.1, Personal Edition +LispWorks, 5.0 - 5.0.2, Professional Edition + +- CLASS-DIRECT-DEFAULT-INITARGS and CLASS-DEFAULT-INITARGS don't return canonicalized default initargs as specified. Not fixed. +- ADD-METHOD, REMOVE-METHOD, INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE do not determine a new discriminating function. This is postponed until function invocation instead, so shouldn't be a problem in practice. +- COMPUTE-APPLICABLE-METHODS-USING-CLASSES doesn't exist. Not fixed. +- COMPUTE-DEFAULT-INITARGS doesn't exist. Not fixed. +- DEFGENERIC does not call FIND-METHOD-COMBINATION. Not fixed. +- EQL-SPECIALIZER, EQL-SPECIALIZER-OBJECT and INTERN-EQL-SPECIALIZER don't exist. In LispWorks, eql specializers are lists not objects. I have provided EQL-SPECIALIZER as a type (not as a class) and EQL-SPECIALIZER-OBJECT and INTERN-EQL-SPECIALIZER to work on lists, and a class EQL-SPECIALIZER* and corresponding EQL-SPECIALIZER-OBJECT* and INTERN-EQL-SPECILAIZER* to soften the incompatibilities. +- The :ALLOCATION type cannot be extended. Not fixed. +- FIND-METHOD-COMBINATION doesn't exist. Fixed, but fixed version doesn't work with method combination options. +- FUNCALLABLE-STANDARD-INSTANCE-ACCESS and STANDARD-INSTANCE-ACCESS don't exist. Not fixed. +- The function invocation protocol doesn't call COMPUTE-APPLICABLE-METHODS and COMPUTE-APPLICABLE-METHODS-USING-CLASSES. Not fixed. +- MAKE-METHOD-LAMBDA expects other parameters than specified. Fixed. +- Method functions don't take parameters as specified in AMOP, but instead just the parameters that the generic function receives. Not fixed. +- The slot methods (SLOT-VALUE-USING-CLASS, etc.) are not specialized on effective slot definitions, but on slot names. Fixed. +- The generated accessor methods don't use the slot methods for accessing slots. Fixed. (Don't use :optimize-slot-access to deoptimize slot access, or otherwise the fixed slot access protocol doesn't work anymore!) +- SPECIALIZER doesn't exist. Not fixed. +- SPECIALIZER-DIRECT-GENERIC-FUNCTIONS doesn't exist. Fixed. +- STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. Not fixed. +- Subclasses of BUILT-IN-CLASS (fixed), CLASS (fixed), DIRECT-SLOT-DEFINITION, EFFECTIVE-SLOT-DEFINITION, FORWARD-REFERENCED-CLASS (fixed), FUNCALLABLE-STANDARD-CLASS (fixed), SLOT-DEFINITION, STANDARD-ACCESSOR-METHOD, STANDARD-CLASS (fixed), STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed, except where indicated otherwise. + + +MCL 5.1 + +In MCL, generic functions work completely differently than specified. The specific incompatibilities are not listed and are not fixed. + +- The slot order requested by a primary method for COMPUTE-SLOTS is not honoured by this MOP. Not fixed. +- DIRECT-SLOT-DEFINITION, EFFECTIVE-SLOT-DEFINITION, EQL-SPECIALIZER, SLOT-DEFINITION and STANDARD-SLOT-DEFINITION are not exported. Fixed. +- When classes are initialized, :direct-superclasses are by default not empty. Not fixed, but direct superclasses are automatically adjusted when you use the standard idiom for adding a new default superclass. +- The :ALLOCATION type cannot be extended. Not fixed. +- Multiple slot options are not passed as lists to DIRECT-SLOT-DEFINITION-CLASS. Not fixed, but use FIX-SLOT-INITARGS as a workaround. +- (SETF CLASS-NAME) doesn't use REINITIALIZE-INSTANCE for changing the names. Fixed. +- REINITIALIZE-INSTANCE of a class metaobject doesn't invoke FINALIZE-INHERITANCE again. Not fixed. +- Subclasses of DIRECT-SLOT-DEFINITION, EFFECTIVE-SLOT-DEFINITION, SLOT-DEFINITION, STANDARD-ACCESSOR-METHOD, STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. + +OpenMCL 1.0 + +In OpenMCL, generic functions work completely differently than specified. The specific incompatibilities are not listed and are not fixed. + +- The slot order requested by a primary method for COMPUTE-SLOTS is not honoured by this MOP. Not fixed. +- EQL-SPECIALIZER is not exported. Fixed. +- DOCUMENTATION doesn't return the documentation strings for slot definition metaobjects. Fixed. +- REINITIALIZE-INSTANCE of a class metaobject doesn't invoke FINALIZE-INHERITANCE again. Not fixed. +- Subclasses of DIRECT-SLOT-DEFINITION, EFFECTIVE-SLOT-DEFINITION, GENERIC-FUNCTION, SLOT-DEFINITION, STANDARD-ACCESSOR-METHOD, STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. + +SBCL 0.9.16 - 1.0.10 + +All features implemented. + + +Summary: + +- CLASS-DIRECT-DEFAULT-INITARGS and CLASS-DEFAULT-INITARGS exist, but don't work as expected in Allegro Common Lisp, CMUCL and LispWorks. +- If you specialize COMPUTE-DEFAULT-INITAGS, conditionalize for the extra parameters in Allegro Common Lisp. +- In Allegro Common Lisp, FUNCALLABLE-STANDARD-OBJECT is not used as the default superclass for classes with :metaclass FUNCALLABLE-STANDARD-CLASS. +- In CMUCL, the object returned by compute-discriminating-function cannot be a closure. Likewise, the second parameter to set-funcallable-instance-function cannot be a closure, but only a "pure" function/thunk. +- In CLisp, MCL and OpenMCL, the slot order requested by a primary method for COMPUTE-SLOTS is not honoured by the respective MOPs. +- Don't rely on FIND-METHOD-COMBINATION to do its job correctly, only when you don't provide method combination options. +- MAKE-METHOD-LAMBDA only works in CMUCL and SBCL as specified (but make sure that the respective generic function and method metaobject classes and make-method-lambda definitions are part of your compilation enviroment). MAKE-METHOD-LAMBDA also works in LispWorks, but the returned lambda expressions don't adhere to the AMOP specification (which may be good enough for your purposes). +- Specialize the methods for the dependent protocol on the class or generic function metaobject class. The example in AMOP doesn't do this but that is fragile code. +- Don't rely on methods being initialized with the specified initargs from inside the MOP. +- CLisp doesn't change a FORWARD-REFERENCED-CLASS via CHANGE-CLASS. Apart from that, FORWARD-REFERENCED-CLASS works reliably across all MOPs. +- Effective slot definitions and EFFECTIVE-SLOT-DEFINITION-CLASS don't receive :documentation in CMUCL, and no :allocation (!) in LispWorks before 5.0. +- If you specialize DIRECT-SLOT-DEFINITION-CLASS, use FIX-SLOT-INITARGS in portable code. +- If you want to use :ALLOCATION types other than :CLASS or :INSTANCE, you cannot use CLisp before 2.37, LispWorks or MCL. Only Allegro Common Lisp, CLisp from 2.37 on, CMUCL, OpenMCL and SBCL support this. +- In Allegro, CMUCL and LispWorks, STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. +- The function invocation protocol only works in CMUCL, SBCL and CLisp. +- If you need to see :direct-default-initargs when classes are initialized, conditionalize on #+lispworks to receive :default-initargs instead for LispWorks version before 5.0. +- COMPUTE-DEFAULT-INITARGS doesn't exist (and isn't called) in LispWorks. +- In LispWorks, eql specializers are lists. +- FUNCALLABLE-STANDARD-INSTANCE-ACCESS and STANDARD-INSTANCE-ACCESS doesn't exist / should not be used in LispWorks. +- In CLisp before version 2.40, and in CMUCL, MCL and OpenMCL, the reinitialization of a class metaobject does not lead to a call of FINALIZE-INHERITANCE, so methods defined on FINALIZE-INHERITANCE won't be called again in that case. +- If you need to see :declarations when generic functions are initialized, conditionalize on #+lispworks to receive 'declare instead for LispWorks versions before 5.0. (Actually, AMOP and ANSI Common Lisp diverge in this regard. AMOP specifies that :declarations is used whereas ANSI Common Lisp specifies that 'declare is used. Since most MOP implementations adhere to AMOP in this regard, I have also chosen that path.) +- In Allegro Common Lisp and LispWorks, method functions take the original parameters that a generic function has received. +- In LispWorks before 5.0, the class SPECIALIZER doesn't exist. +- If you need to rely on the generic function protocols, don't use MCL or OpenMCL (or be very careful - some minor things work there as specified). +- The declarations for a generic function cannot be inspected in MCL. +- All implementations define slots on various specified metaobject classes that are exported from some package and/or accessible in the package common-lisp-user. Only sbcl is safe from this, and clisp is relatively safe in that it does that only for the class METHOD-COMBINATION.

Added: branches/trunk-reorg/thirdparty/closer-mop/lispworks/closer-mop-packages.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/lispworks/closer-mop-packages.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/lispworks/closer-mop-packages.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,194 @@ +(in-package :cl-user) + +(defpackage #:closer-mop + (:use #:common-lisp #:lispworks) + (:nicknames #:c2mop) + + (:shadow + #:defclass #:defgeneric #:defmethod + #:ensure-generic-function + #:standard-class #:standard-generic-function) + (:export + #:defclass #:defgeneric #:defmethod + #:ensure-generic-function + #:standard-class #:standard-generic-function) + + (:import-from #:clos + + #:direct-slot-definition + #:effective-slot-definition + #-lispworks #:eql-specializer + #:forward-referenced-class + #-lispworks #:funcallable-standard-class + #+lispworks5.0 #:funcallable-standard-object + #:metaobject + #:slot-definition + #-lispworks #:specializer + #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + + #-lispworks4.3 #:accessor-method-slot-definition + #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #-lispworks #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #-lispworks #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #-lispworks #:eql-specializer-object + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #-lispworks #:find-method-combination + #-lispworks #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #-lispworks #:intern-eql-specializer + #-lispworks #:make-method-lambda + #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #-lispworks4.3 #:reader-method-class + #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #-lispworks #:specializer-direct-generic-functions + #:specializer-direct-methods + #-lispworks #:standard-instance-access + #:update-dependent + #:validate-superclass + #-lispworks4.3 #:writer-method-class) + + (:export + #:direct-slot-definition + #:effective-slot-definition + #:eql-specializer + #+lispworks #:eql-specializer* + #:forward-referenced-class + #:funcallable-standard-class + #:funcallable-standard-object + #:metaobject + #:slot-definition + #-lispworks #:specializer + #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + + #:ensure-finalized + #:ensure-method + #:fix-slot-initargs + #:required-args + + #-lispworks4.3 #:accessor-method-slot-definition + #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #-lispworks #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #-lispworks #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #:eql-specializer-object + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #:find-method-combination + #-lispworks #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #:intern-eql-specializer + #+lispworks #:intern-eql-specializer* + #:make-method-lambda + #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #-lispworks4.3 #:reader-method-class + #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #:specializer-direct-generic-functions + #:specializer-direct-methods + #-lispworks #:standard-instance-access + #:update-dependent + #:validate-superclass + #-lispworks4.3 #:writer-method-class))

Added: branches/trunk-reorg/thirdparty/closer-mop/lispworks/closer-mop.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/lispworks/closer-mop.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/lispworks/closer-mop.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,605 @@ +(in-package :closer-mop) + +;; Some utility functions. + +(defun required-args (lambda-list &optional (collector #'identity)) + (loop for arg in lambda-list + until (member arg lambda-list-keywords) + collect (funcall collector arg))) + +(defun ensure-finalized (class &optional (errorp t)) + (if (typep class 'class) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (when errorp (error "~S is not a class." class))) + class) + +;; We need a new standard-generic-function for various things. + +(cl:defclass standard-generic-function (cl:standard-generic-function) + ((initial-methods :initform '())) + (:metaclass clos:funcallable-standard-class)) + +;; The following ensures that the new standard-generic-function is used. + +(defun ensure-generic-function + (name &rest args + &key (generic-function-class 'standard-generic-function) + &allow-other-keys) + (declare (dynamic-extent args)) + (when (fboundp name) + (let ((function (fdefinition name))) + (unless (typep function 'generic-function) + (cerror "Discard existing definition and create generic function." + "~S is already fbound, but not as a generic function." name) + (fmakunbound name)))) + (if (fboundp name) + (let ((function (fdefinition name))) + (apply #'ensure-generic-function-using-class + function name args)) + (apply #'ensure-generic-function-using-class nil name + :generic-function-class generic-function-class + args))) + +;; We need a new standard-class for various things. + +(cl:defclass standard-class (cl:standard-class) + ()) + +;; validate-superclass for metaclass classes is a little bit +;; more tricky than for class metaobject classes because +;; we don't want to make all standard-classes compatible to +;; each other. + +;; Our validate-superclass may get passed a class-prototype +;; as its second argument, so don't expect its readers to +;; yield useful information. (In ANSI parlance, "the +;; consequences are undefined...") + +(cl:defmethod validate-superclass + ((class standard-class) + (superclass cl:standard-class)) + (or (when (eq (class-of class) (find-class 'standard-class)) + (or (eq (class-of superclass) (find-class 'cl:standard-class)) + (eq (class-of superclass) (find-class 'standard-class)))) + (call-next-method) + (when (eq (class-of superclass) (find-class 'cl:standard-class)) + (validate-superclass class (class-prototype (find-class 'standard-class)))))) + +;; The following macro ensures that the new standard-class is used +;; by default. It would have been useful to fix other deficiencies +;; in a complete redefinition of defclass, but there is no portable +;; way to ensure the necessary compile-time effects as specified +;; by ANSI Common Lisp. Therefore, we just expand to the original +;; cl:defclass. + +(defmacro defclass (name (&rest supers) &body options) + (if (member :metaclass options :key #'car) + `(cl:defclass ,name ,supers ,@options) + `(cl:defclass ,name ,supers ,@options + (:metaclass standard-class)))) + +;; We need a new funcallable-standard-class for various things. + +(cl:defclass funcallable-standard-class (clos:funcallable-standard-class) + ()) + +;; See the comment on validate-superclass for standard-class above. + +(cl:defmethod validate-superclass + ((class funcallable-standard-class) + (superclass clos:funcallable-standard-class)) + (or (when (eq (class-of class) (find-class 'funcallable-standard-class)) + (or (eq (class-of superclass) (find-class 'clos:funcallable-standard-class)) + (eq (class-of superclass) (find-class 'funcallable-standard-class)))) + (call-next-method) + (when (eq (class-of superclass) (find-class 'clos:funcallable-standard-class)) + (validate-superclass class (class-prototype (find-class 'funcallable-standard-class)))))) + +#+lispworks5.0 +(cl:defmethod validate-superclass + ((class funcallable-standard-class) + (superclass (eql (find-class 'funcallable-standard-object)))) + t) + +;; We also need a new funcallable-standard-object because the default one +;; is not an instance of clos:funcallable-standard-class. + +#-lispworks5.0 +(cl:defclass funcallable-standard-object (clos:funcallable-standard-object) + () + (:metaclass clos:funcallable-standard-class)) + +;; The following code ensures that possibly incorrect lists of direct +;; superclasses are corrected. + +#-lispworks5.0 +(defun modify-superclasses (direct-superclasses &optional (standardp t)) + (if (null direct-superclasses) + (list (if standardp + (find-class 'standard-object) + (find-class 'funcallable-standard-object))) + (let ((standard-object (if standardp + (find-class 'standard-object) + (find-class 'clos:funcallable-standard-object)))) + (if (eq (car (last direct-superclasses)) standard-object) + (if standardp + direct-superclasses + (append (butlast direct-superclasses) + (list (find-class 'funcallable-standard-object)))) + (remove standard-object direct-superclasses))))) + +;; During class re/initialization, we take care of the following things: +;; - Optimization of slot accessors is deactivated. +;; - Lists of direct superclasses are corrected. +;; - Removal of direct subclasses. + +(cl:defmethod initialize-instance :around + ((class standard-class) &rest initargs + #-lispworks5.0 &key + #-lispworks5.0 (direct-superclasses ())) + (declare (dynamic-extent initargs)) + (apply #'call-next-method class + #-lispworks5.0 :direct-superclasses + #-lispworks5.0 (modify-superclasses direct-superclasses) + :optimize-slot-access nil + initargs)) + +(cl:defmethod reinitialize-instance :around + ((class standard-class) &rest initargs + #-lispworks5.0 &key + #-lispworks5.0 (direct-superclasses () direct-superclasses-p)) + (declare (dynamic-extent initargs)) + #-lispworks5.0 + (progn + (when direct-superclasses-p + (setq direct-superclasses (modify-superclasses direct-superclasses)) + (loop for superclass in (copy-list (class-direct-superclasses class)) + unless (member superclass direct-superclasses) + do (remove-direct-subclass superclass class))) + (if direct-superclasses-p + (apply #'call-next-method class + :direct-superclasses direct-superclasses + :optimize-slot-access nil + initargs) + (apply #'call-next-method class + :optimize-slot-access nil + initargs))) + #+lispworks5.0 + (apply #'call-next-method class + :optimize-slot-access nil + initargs)) + +(cl:defmethod initialize-instance :around + ((class funcallable-standard-class) &rest initargs + #-lispworks5.0 &key + #-lispworks5.0 (direct-superclasses ())) + (declare (dynamic-extent initargs)) + (apply #'call-next-method class + #-lispworks5.0 :direct-superclasses + #-lispworks5.0 (modify-superclasses direct-superclasses nil) + :optimize-slot-access nil + initargs)) + +(cl:defmethod reinitialize-instance :around + ((class funcallable-standard-class) &rest initargs + #-lispworks5.0 &key + #-lispworks5.0 (direct-superclasses () direct-superclasses-p)) + (declare (dynamic-extent initargs)) + #-lispworks5.0 + (progn + (when direct-superclasses-p + (setq direct-superclasses (modify-superclasses direct-superclasses nil)) + (loop for superclass in (copy-list (class-direct-superclasses class)) + unless (member superclass direct-superclasses) + do (remove-direct-subclass superclass class))) + (if direct-superclasses-p + (apply #'call-next-method class + :direct-superclasses direct-superclasses + :optimize-slot-access nil + initargs) + (apply #'call-next-method class + :optimize-slot-access nil + initargs))) + #+lispworks5.0 + (apply #'call-next-method class + :optimize-slot-access nil + initargs)) + +;; The following is necessary for forward-referenced-classes. +;; Since we replace the original funcallable-standard-object with +;; a new one, we have to prevent LispWorks from trying to use +;; the original one when forward-ferenced-classes are resolved. + +#-lispworks5.0 +(cl:defmethod change-class :around + ((class forward-referenced-class) + (new-class funcallable-standard-class) + &rest initargs + &key (direct-superclasses ())) + (declare (dynamic-extent initargs)) + (apply #'call-next-method class new-class + :optimize-slot-access nil + :direct-superclasses (modify-superclasses direct-superclasses nil) + initargs)) + +;;; In LispWorks, the slot accessors (slot-value-using-class, etc.) are specialized +;;; on slot names instead of effective slot definitions. In order to fix this, +;;; we need to rewire the slot access protocol. + +(cl:defmethod slot-value-using-class + ((class standard-class) object (slot symbol)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (let ((slotd (find slot (class-slots class) + :test #'eq + :key #'slot-definition-name))) + (if slotd + (slot-value-using-class class object slotd) + (slot-missing class object slot 'slot-value)))) + +(cl:defmethod slot-value-using-class + ((class standard-class) object (slotd standard-effective-slot-definition)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (slot-value-using-class + (load-time-value (class-prototype (find-class 'cl:standard-class))) + object + (slot-definition-name slotd))) + +(cl:defmethod (setf slot-value-using-class) + (new-value (class standard-class) object (slot symbol)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (let ((slotd (find slot (class-slots class) + :test #'eq + :key #'slot-definition-name))) + (if slotd + (setf (slot-value-using-class class object slotd) + new-value) + (slot-missing class object slot 'setf new-value)))) + +(cl:defmethod (setf slot-value-using-class) + (new-value (class standard-class) object (slotd standard-effective-slot-definition)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (setf (slot-value-using-class + (load-time-value (class-prototype (find-class 'cl:standard-class))) + object + (slot-definition-name slotd)) + new-value)) + +(cl:defmethod slot-boundp-using-class + ((class standard-class) object (slot symbol)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (let ((slotd (find slot (class-slots class) + :test #'eq + :key #'slot-definition-name))) + (if slotd + (slot-boundp-using-class class object slotd) + (slot-missing class object slot 'slot-boundp)))) + +(cl:defmethod slot-boundp-using-class + ((class standard-class) object (slotd standard-effective-slot-definition)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (slot-boundp-using-class + (load-time-value (class-prototype (find-class 'cl:standard-class))) + object + (slot-definition-name slotd))) + +(cl:defmethod slot-makunbound-using-class + ((class standard-class) object (slot symbol)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (let ((slotd (find slot (class-slots class) + :test #'eq + :key #'slot-definition-name))) + (if slotd + (slot-makunbound-using-class class object slotd) + (slot-missing class object slot 'slot-makunbound)))) + +(cl:defmethod slot-makunbound-using-class + ((class standard-class) object (slotd standard-effective-slot-definition)) + (declare (optimize (speed 3) (debug 0) (safety 0) + (compilation-speed 0))) + (slot-makunbound-using-class + (load-time-value (class-prototype (find-class 'cl:standard-class))) + object + (slot-definition-name slotd))) + +;; In LispWorks, eql specializers are lists. We cannot change this +;; but we can soften some of the incompatibilities. + +(deftype eql-specializer () + '(or eql-specializer* + (satisfies clos:eql-specializer-p))) + +(cl:defgeneric eql-specializer-object (eql-specializer) + (:method ((cons cons)) + (if (clos:eql-specializer-p cons) + (cadr cons) + (error "~S is not an eql-specializer." cons)))) + +(defun intern-eql-specializer (object) + `(eql ,object)) + +(cl:defclass eql-specializer* (metaobject) + ((obj :reader eql-specializer-object + :initarg eso + :initform (error "Use intern-eql-specializer to create eql-specializers.")) + (direct-methods :reader specializer-direct-methods + :accessor es-direct-methods + :initform ()))) + +(defvar *eql-specializers* (make-hash-table)) + +(defun intern-eql-specializer* (object) + (or (gethash object *eql-specializers*) + (setf (gethash object *eql-specializers*) + (make-instance 'eql-specializer* 'eso object)))) + +(cl:defmethod add-direct-method ((specializer eql-specializer*) (method method)) + (pushnew method (es-direct-methods specializer))) + +(cl:defmethod remove-direct-method ((specializer eql-specializer*) (method method)) + (removef (es-direct-methods specializer) method)) + +(cl:defgeneric specializer-direct-generic-functions (specializer) + (:method ((class class)) + (remove-duplicates + (mapcar #'method-generic-function + (specializer-direct-methods class)))) + (:method ((eql-specializer eql-specializer*)) + (remove-duplicates + (mapcar #'method-generic-function + (specializer-direct-methods eql-specializer)))) + (:method ((cons cons)) + (specializer-direct-generic-functions + (intern-eql-specializer* + (eql-specializer-object cons))))) + +;; The following method ensures that remove-method is called. + +#-lispworks5.0 +(cl:defmethod add-method :before ((gf standard-generic-function) (method method)) + (when-let (old-method (find-method gf (method-qualifiers method) + (method-specializers method) nil)) + (remove-method gf old-method))) + +;; The following two methods ensure that add/remove-direct-method is called, +;; and that the dependent protocol for generic function works. + +(cl:defmethod add-method :after ((gf standard-generic-function) (method method)) + (loop for specializer in (method-specializers method) + if (consp specializer) + do (add-direct-method + (intern-eql-specializer* + (eql-specializer-object specializer)) + method) + #-lispworks5.0 else + #-lispworks5.0 do + #-lispworks5.0 (add-direct-method specializer method)) + #+lispworks4.3 + (map-dependents + gf (lambda (dep) (update-dependent gf dep 'add-method method)))) + +(cl:defmethod remove-method :after ((gf standard-generic-function) (method method)) + (loop for specializer in (method-specializers method) + if (consp specializer) + do (remove-direct-method + (intern-eql-specializer* + (eql-specializer-object specializer)) + method) + #-lispworks5.0 else + #-lispworks5.0 do + #-lispworks5.0 (remove-direct-method specializer method)) + #+lispworks4.3 + (map-dependents + gf (lambda (dep) (update-dependent gf dep 'remove-method method)))) + +(cl:defgeneric find-method-combination (gf combi combi-options) + (:method ((gf generic-function) (combi symbol) combi-options) + (when combi-options + (error "This implementation of find-method-combination cannot handle method combination options.")) + (clos::find-a-method-combination-type combi))) + +;; In LispWorks, make-method-lambda expects different arguments than those +;; specified in AMOP. We just bridge this. The method lambda returned +;; still doesn't conform to AMOP, but may be good enough. + +(cl:defgeneric make-method-lambda (gf method lambda-expression env) + (:method ((gf cl:standard-generic-function) + (method standard-method) + lambda-expression env) + (declare (ignorable env)) + (destructuring-bind + (lambda (&rest args) &body body) + lambda-expression + (declare (ignore lambda)) + (loop with documentation = :unbound + for (car . cdr) = body then cdr + while (or (stringp car) + (and (consp car) (eq (car car) 'declare))) + if (stringp car) + do (setf documentation + (if (eq documentation :unbound) car + (error "Too many documentation strings in lambda expression ~S." + lambda-expression))) + else append (loop for declaration in (cdr car) + if (eq (car declaration) 'ignore) + collect `(ignorable ,@(cdr declaration)) + and collect `(dynamic-extent ,@(cdr declaration)) + else collect declaration) into declarations + finally (multiple-value-bind + (method-lambda method-args) + (clos:make-method-lambda + gf method args declarations + `(progn ,car ,@cdr) env) + (if (eq documentation :unbound) + (return (values method-lambda method-args)) + (return (values + `(lambda ,(cadr method-lambda) + ,documentation + ,@(cddr method-lambda)) + method-args)))))))) + +(defun ensure-method (gf lambda-expression + &key (method-class (generic-function-method-class gf)) + (qualifiers ()) + (lambda-list (cadr lambda-expression)) + (specializers (required-args lambda-list (constantly (find-class 't))))) + (multiple-value-bind + (method-lambda method-args) + (make-method-lambda + gf (class-prototype method-class) + lambda-expression ()) + (let ((method (apply #'make-instance + method-class + :qualifiers qualifiers + :lambda-list lambda-list + :specializers specializers + :function (compile nil method-lambda) + method-args))) + (add-method gf method) + method))) + +;; helper function for creating a generic function lambda list +;; from a method lambda list. +(defun create-gf-lambda-list (method-lambda-list) + (loop with stop-keywords = '#.(remove '&optional lambda-list-keywords) + for arg in method-lambda-list + until (member arg stop-keywords) + collect arg into gf-lambda-list + finally (return (let (rest) + (cond ((member '&key method-lambda-list) + (nconc gf-lambda-list '(&key))) + ((setq rest (member '&rest method-lambda-list)) + (nconc gf-lambda-list (subseq rest 0 2))) + (t gf-lambda-list)))))) + +;; The defmethod macro is needed in order to ensure that make-method-lambda +;; is called. (Unfortunately, this doesn't work in the other CL implementations.) + +(defmacro defmethod (&whole form name &body body &environment env) + (loop for tail = body then (cdr tail) + until (listp (car tail)) + collect (car tail) into qualifiers + finally + (destructuring-bind + ((&rest specialized-args) &body body) tail + (loop with documentation = :unbound + for (car . cdr) = body then cdr + while (or (stringp car) + (and (consp car) (eq (car car) 'declare))) + if (stringp car) + do (setq documentation + (if (eq documentation :unbound) car + (error "Too many documentation strings for defmethod form ~S." form))) + else append (cdr car) into declarations + finally + (let* ((lambda-list (extract-lambda-list specialized-args)) + (gf-lambda-list (create-gf-lambda-list lambda-list)) + (gf (if (fboundp name) + (ensure-generic-function name) + (ensure-generic-function name :lambda-list gf-lambda-list))) + (method-class (generic-function-method-class gf)) + (lambda-expression `(lambda ,lambda-list + (declare ,@declarations) + (block ,name ,car ,@cdr)))) + (if (equal (compute-applicable-methods + #'make-method-lambda + (list gf (class-prototype method-class) + lambda-expression env)) + (list (find-method + #'make-method-lambda '() + (list (find-class 'cl:standard-generic-function) + (find-class 'standard-method) + (find-class 't) + (find-class 't)) + nil))) + (return-from defmethod `(cl:defmethod ,@(rest form))) + (multiple-value-bind + (method-lambda method-args) + (make-method-lambda + gf (class-prototype method-class) + lambda-expression env) + (with-unique-names (gf method) + (return-from defmethod + `(let ((,gf (if (fboundp ',name) + (ensure-generic-function ',name) + (ensure-generic-function + ',name :lambda-list ',gf-lambda-list))) + (,method + (make-instance + ',method-class + :qualifiers ',qualifiers + :specializers + (list + ,@(mapcar + (lambda (specializer-name) + (typecase specializer-name + (symbol `(find-class ',specializer-name)) + (cons (cond + ((> (length specializer-name) 2) + (error "Invalid specializer ~S in defmethod form ~S." + specializer-name form)) + ((eq (car specializer-name) 'eql) + `(intern-eql-specializer ,(cadr specializer-name))) + (t (error "Invalid specializer ~S in defmethod form ~S." + specializer-name form)))) + (t (error "Invalid specializer ~S in defmethod form ~S." + specializer-name form)))) + (extract-specializer-names specialized-args))) + :lambda-list ',lambda-list + :function (function ,method-lambda) + ,@(unless (eq documentation :unbound) + (list :documentation documentation)) + ,@method-args))) + (add-method ,gf ,method) + ,method)))))))))) + +;; The following macro ensures that the new standard-generic-function +;; is used by default. It also ensures that make-method-lambda is called +;; for the default methods, by expanding into defmethod forms. + +(defmacro defgeneric (&whole form name (&rest args) &body options) + (unless (every #'consp options) + (error "Illegal generic functions options in defgeneric form ~S." form)) + `(progn + (let ((generic-function (ignore-errors (fdefinition ',name)))) + (when (and generic-function (typep generic-function 'standard-generic-function)) + (loop for method in (slot-value generic-function 'initial-methods) + do (remove-method generic-function method)))) + (cl:defgeneric ,name ,args + ,@(remove :method options :key #'car :test #'eq) + ,@(unless (member :generic-function-class options :key #'car :test #'eq) + '((:generic-function-class standard-generic-function)))) + (let ((generic-function (fdefinition ',name))) + (setf (slot-value generic-function 'initial-methods) + (list ,@(loop for method-spec in (remove :method options :key #'car :test-not #'eq) + collect `(defmethod ,name ,@(cdr method-spec))))) + generic-function))) + +;; The following can be used in direct-slot-definition-class to get the correct initargs +;; for a slot. Use it like this: +;; +;; (defmethod direct-slot-definition-class +;; ((class my-standard-class) &rest initargs) +;; (declare (dynamic-extent initargs)) +;; (destructuring-bind +;; (&key key-of-interest &allow-other-keys) +;; (fix-slot-initargs initargs) +;; ...)) + +(defvar *standard-slot-keys* + '(:name :documentation + :initargs :initform :initfunction + :readers :writers)) + +(defun fix-slot-initargs (initargs) + initargs) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew :closer-mop *features*))

Added: branches/trunk-reorg/thirdparty/closer-mop/mcl/closer-mop-packages.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/mcl/closer-mop-packages.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/mcl/closer-mop-packages.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,190 @@ +(in-package :cl-user) + +(defpackage #:closer-mop + (:use #:common-lisp #:lispworks) + (:nicknames #:c2mop) + + #-openmcl + (:shadow #:defclass #:standard-class #:typep #:subtypep) + #-openmcl + (:export #:defclass #:standard-class #:typep #:subtypep) + + (:import-from #:ccl + + #:direct-slot-definition + #:effective-slot-definition + #:eql-specializer + #:forward-referenced-class + #:funcallable-standard-class + #-(or mcl openmcl) #:funcallable-standard-object + #:metaobject + #:slot-definition + #:specializer + #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + + #:accessor-method-slot-definition + #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #-(or mcl openmcl) #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #:eql-specializer-object + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #:find-method-combination + #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #:intern-eql-specializer + #-(or mcl openmcl) #:make-method-lambda + #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #:reader-method-class + #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #+openmcl #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #:specializer-direct-generic-functions + #:specializer-direct-methods + #:standard-instance-access + #:update-dependent + #:validate-superclass + #:writer-method-class) + + (:export + #:direct-slot-definition + #:effective-slot-definition + #:eql-specializer + #:forward-referenced-class + #:funcallable-standard-class + #-(or mcl openmcl) #:funcallable-standard-object + #:metaobject + #:slot-definition + #:specializer + #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + + #:ensure-finalized + #:ensure-method + #:fix-slot-initargs + #:required-args + + #:accessor-method-slot-definition + #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #-(or mcl openmcl) #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #:eql-specializer-object + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #:find-method-combination + #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #:intern-eql-specializer + #-(or mcl openmcl) #:make-method-lambda + #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #:reader-method-class + #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #+openmcl #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #:specializer-direct-generic-functions + #:specializer-direct-methods + #:standard-instance-access + #-openmcl #:subtypep + #-openmcl #:typep + #:update-dependent + #:validate-superclass + #:writer-method-class))

Added: branches/trunk-reorg/thirdparty/closer-mop/mcl/closer-mop.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/mcl/closer-mop.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/mcl/closer-mop.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,177 @@ +(in-package :closer-mop) + +;; Some utility functions. + +(defun required-args (lambda-list &optional (collector #'identity)) + (loop for arg in lambda-list + until (member arg lambda-list-keywords) + collect (funcall collector arg))) + +(defun ensure-finalized (class &optional (errorp t)) + (if (typep class 'class) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (when errorp (error "~S is not a class." class))) + class) + +#-openmcl +(progn + ;; We need a new standard-class for various things. + + (cl:defclass standard-class (cl:standard-class) + ()) + + ;; validate-superclass for metaclass classes is a little bit + ;; more tricky than for class metaobject classes because + ;; we don't want to make all standard-classes compatible to + ;; each other. + + ;; Our validate-superclass may get passed a class-prototype + ;; as its second argument, so don't expect its readers to + ;; yield useful information. (In ANSI parlance, "the + ;; consequences are undefined...") + + (cl:defmethod validate-superclass + ((class standard-class) + (superclass cl:standard-class)) + (or (when (eq (class-of class) (find-class 'standard-class)) + (or (eq (class-of superclass) (find-class 'cl:standard-class)) + (eq (class-of superclass) (find-class 'standard-class)))) + (call-next-method) + (when (eq (class-of superclass) (find-class 'cl:standard-class)) + (validate-superclass class (class-prototype (find-class 'standard-class)))))) + + ;; The following macro ensures that the new standard-class is used + ;; by default. It would have been useful to fix other deficiencies + ;; in a complete redefinition of defclass, but there is no portable + ;; way to ensure the necessary compile-time effects as specified + ;; by ANSI Common Lisp. Therefore, we just expand to the original + ;; cl:defclass. + + (defmacro defclass (name (&rest supers) &body options) + (if (member :metaclass options :key #'car) + `(cl:defclass ,name ,supers ,@options) + `(cl:defclass ,name ,supers ,@options + (:metaclass standard-class)))) + + ;; In MCL, the list of direct superclasses passed by the + ;; defclass macro is not empty, as required by AMOP, but + ;; instead passes the class metaobject for standard-object + ;; or funcallable-standard-object respectively. This makes + ;; replacing the default superclass for a new metaclass a bit + ;; more complicated. In order to avoid the tricky bits in user + ;; code, the new standard-class adjusts possible incorrect + ;; direct superclasses by adding or removing the metaobject + ;; for standard-object as needed before passing them to + ;; the original standard-class. In user code, just use the + ;; idiom suggested by AMOP to APPEND your new default superclass + ;; to the list of direct superclasses. + + (defun modify-superclasses (direct-superclasses) + (if (null direct-superclasses) + (list (find-class 'standard-object)) + (let ((standard-object (find-class 'standard-object))) + (if (eq (car (last direct-superclasses)) standard-object) + direct-superclasses + (remove standard-object direct-superclasses))))) + + (cl:defmethod initialize-instance :around + ((class standard-class) &rest initargs + &key (name (gensym)) (direct-superclasses ())) + (declare (dynamic-extent initargs)) + (apply #'call-next-method class + :name name + :direct-superclasses (modify-superclasses direct-superclasses) + initargs)) + + (cl:defmethod reinitialize-instance :around + ((class standard-class) &rest initargs + &key (direct-superclasses () direct-superclasses-p)) + (declare (dynamic-extent initargs)) + (if direct-superclasses-p + (apply #'call-next-method class + :direct-superclasses (modify-superclasses direct-superclasses) + initargs) + (call-next-method))) + + (defgeneric typep (object type) + (:method (object type) + (cl:typep object type)) + (:method (object (type class)) + (member (class-of object) + (class-precedence-list type)))) + + (defgeneric subtypep (type1 type2) + (:method (type1 type2) + (cl:subtypep type1 type2)) + (:method ((type1 class) (type2 symbol)) + (let ((class2 (find-class type2 nil))) + (if class2 + (member class2 (class-precedence-list type1)) + (cl:subtypep type1 type2)))) + (:method ((type1 symbol) (type2 class)) + (let ((class1 (find-class type1 nil))) + (if class1 + (member type2 (class-precedence-list class1)) + (cl:subtypep type1 type2)))) + (:method ((type1 class) (type2 class)) + (member type2 (class-precedence-list type1))))) + +(defun ensure-method (gf lambda-expression + &key (qualifiers ()) + (lambda-list (cadr lambda-expression)) + (specializers (required-args lambda-list (constantly (find-class 't))))) + (eval `(defmethod ,(generic-function-name gf) ,@qualifiers + ,(loop for specializer in specializers + for (arg . rest) on lambda-list + collect `(,arg ,specializer) into args + finally (return (nconc args rest))) + ,@(cddr lambda-expression)))) + +;; The following ensures that slot definitions have a documentation in OpenMCL. + +#+openmcl +(defmethod initialize-instance :after ((slot slot-definition) &key documentation) + (setf (documentation slot 't) documentation)) + +;; The following can be used in direct-slot-definition-class to get the correct initargs +;; for a slot. Use it like this: +;; +;; (defmethod direct-slot-definition-class +;; ((class my-standard-class) &rest initargs) +;; (declare (dynamic-extent initargs)) +;; (destructuring-bind +;; (&key key-of-interest &allow-other-keys) +;; (fix-slot-initargs initargs) +;; ...)) + +(defvar *standard-slot-keys* + '(:name :documentation + :initargs :initform :initfunction + :readers :writers)) + +(defun fix-slot-initargs (initargs) + #+openmcl initargs + #-openmcl + (let* ((counts (loop with counts + for (key nil) on initargs by #'cddr + do (incf (getf counts key 0)) + finally (return counts))) + (keys-to-fix (loop for (key value) on counts by #'cddr + if (> value 1) collect key))) + (if keys-to-fix + (let ((multiple-standard-keys + (intersection keys-to-fix *standard-slot-keys*))) + (if multiple-standard-keys + (error "Too many occurences of ~S in slot initargs ~S." + multiple-standard-keys initargs) + (loop with fixed-keys + for (key value) on initargs by #'cddr + if (member key keys-to-fix) + do (nconcf (getf fixed-keys key) (list value)) + else nconc (list key value) into fixed-initargs + finally (return (nconc fixed-initargs fixed-keys))))) + initargs))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew :closer-mop *features*))

Added: branches/trunk-reorg/thirdparty/closer-mop/pcl/closer-mop-packages.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/pcl/closer-mop-packages.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/pcl/closer-mop-packages.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,190 @@ +(in-package :cl-user) + +(defpackage #:closer-mop + (:use #:common-lisp #:lispworks) + (:nicknames #:c2mop) + + #-sbcl (:shadow #:typep #:subtypep) + #-sbcl (:export #:typep #:subtypep) + + (:import-from + #+cmu #:clos-mop + #+sbcl #:sb-mop + + #:direct-slot-definition + #:effective-slot-definition + #:eql-specializer + #:forward-referenced-class + #:funcallable-standard-class + #:funcallable-standard-object + #:metaobject + #:slot-definition + #:specializer + #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + + #:accessor-method-slot-definition + #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #:eql-specializer-object + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #:find-method-combination + #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #:intern-eql-specializer + #:make-method-lambda + #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #:reader-method-class + #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #:specializer-direct-generic-functions + #:specializer-direct-methods + #:standard-instance-access + #:update-dependent + #:validate-superclass + #:writer-method-class) + + (:export + #:direct-slot-definition + #:effective-slot-definition + #:eql-specializer + #:forward-referenced-class + #:funcallable-standard-class + #:funcallable-standard-object + #:metaobject + #:slot-definition + #:specializer + #:standard-accessor-method + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + + #:ensure-finalized + #:ensure-method + #:fix-slot-initargs + #:required-args + + #:accessor-method-slot-definition + #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-precedence-list + #:class-prototype + #:class-slots + #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition-class + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function-using-class + #:eql-specializer-object + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #:find-method-combination + #:funcallable-standard-instance-access + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #:intern-eql-specializer + #:make-method-lambda + #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #:reader-method-class + #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-writers + #:slot-definition-type + #:slot-makunbound-using-class + #:slot-value-using-class + #:specializer-direct-generic-functions + #:specializer-direct-methods + #:standard-instance-access + #:subtypep + #:typep + #:update-dependent + #:validate-superclass + #:writer-method-class))

Added: branches/trunk-reorg/thirdparty/closer-mop/pcl/closer-mop.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/pcl/closer-mop.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/pcl/closer-mop.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,284 @@ +(in-package :closer-mop) + +;; Some utility functions. + +(defun required-args (lambda-list &optional (collector #'identity)) + (loop for arg in lambda-list + until (member arg lambda-list-keywords) + collect (funcall collector arg))) + +(defun ensure-finalized (class &optional (errorp t)) + (if (typep class 'class) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (when errorp (error "~S is not a class." class))) + class) + +;; The following is commented out. SBCL now supports compatible standard-class and +;; funcallable-standard-class metaclasses, but this requires that we don't mess with +;; the class hierarchy anymore. So we will try the trick we have already used +;; for generic functions: We just add methods for the existing metaclasses. +;; This is not AMOP-compliant, but if it works it works. + +#| +;; We need a new standard-class for various things. + +(cl:defclass standard-class (cl:standard-class) + ()) + +;; validate-superclass for metaclass classes is a little bit +;; more tricky than for class metaobject classes because +;; we don't want to make all standard-classes compatible to +;; each other. + +;; Our validate-superclass may get passed a class-prototype +;; as its second argument, so don't expect its readers to +;; yield useful information. (In ANSI parlance, "the +;; consequences are undefined...") + +(cl:defmethod validate-superclass + ((class standard-class) + (superclass cl:standard-class)) + (or (when (eq (class-of class) (find-class 'standard-class)) + (or (eq (class-of superclass) (find-class 'cl:standard-class)) + (eq (class-of superclass) (find-class 'standard-class)))) + (call-next-method) + (when (eq (class-of superclass) (find-class 'cl:standard-class)) + (validate-superclass class (class-prototype (find-class 'standard-class)))))) + +#+sbcl +(cl:defmethod validate-superclass + ((class funcallable-standard-class) + (superclass standard-class)) + (and (eq (class-of class) (find-class 'funcallable-standard-class)) + (eq (class-of superclass) (find-class 'standard-class)))) + +;; The following macro ensures that the new standard-class is used +;; by default. It would have been useful to fix other deficiencies +;; in a complete redefinition of defclass, but there is no portable +;; way to ensure the necessary compile-time effects as specified +;; by ANSI Common Lisp. Therefore, we just expand to the original +;; cl:defclass. + +(defmacro defclass (name (&rest supers) &body options) + (if (member :metaclass options :key #'car) + `(cl:defclass ,name ,supers ,@options) + `(cl:defclass ,name ,supers ,@options + (:metaclass standard-class)))) +|# + +;; In CMUCL, reader-method-class and writer-method-class are +;; not used during class initialization. The following definitions +;; correct this. + +#-sbcl +(defun modify-accessors (class) + (loop with reader-specializers = (list class) + with writer-specializers = (list (find-class 't) class) + for slotd in (class-direct-slots class) do + (loop for reader in (slot-definition-readers slotd) + for reader-function = (fdefinition reader) + for reader-method = (find-method reader-function () reader-specializers) + for initargs = (list :qualifiers () + :lambda-list '(object) + :specializers reader-specializers + :function (method-function reader-method) + :slot-definition slotd) + for method-class = (apply #'reader-method-class class slotd initargs) + unless (eq method-class (class-of reader-method)) + do (add-method reader-function (apply #'make-instance method-class initargs))) + (loop for writer in (slot-definition-writers slotd) + for writer-function = (fdefinition writer) + for writer-method = (find-method writer-function () writer-specializers) + for initargs = (list :qualifiers () + :lambda-list '(new-value object) + :specializers writer-specializers + :function (method-function writer-method) + :slot-definition slotd) + for method-class = (apply #'writer-method-class class slotd initargs) + unless (eq method-class (class-of writer-method)) + do (add-method writer-function (apply #'make-instance method-class initargs))))) + +;; The following methods additionally create a gensym for the class name +;; unless a name is explicitly provided. AMOP requires classes to be +;; potentially anonymous. + +#-sbcl +(cl:defmethod initialize-instance :around + ((class standard-class) &rest initargs + &key (name (gensym))) + (declare (dynamic-extent initargs)) + (prog1 (apply #'call-next-method class :name name initargs) + (modify-accessors class))) + +#-sbcl +(cl:defmethod initialize-instance :around + ((class funcallable-standard-class) &rest initargs + &key (name (gensym))) + (declare (dynamic-extent initargs)) + (prog1 (apply #'call-next-method class :name name initargs) + (modify-accessors class))) + +#-sbcl +(cl:defmethod reinitialize-instance :after + ((class standard-class) &key) + (modify-accessors class)) + +#-sbcl +(cl:defmethod reinitialize-instance :after + ((class funcallable-standard-class) &key) + (modify-accessors class)) + +;;; The following three methods ensure that the dependent protocol +;;; for generic function works. + +;; The following method additionally ensures that +;; compute-discriminating-function is triggered. + +; Note that for CMUCL, these methods violate the AMOP specification +; by specializing on the original standard-generic-function metaclass. However, +; this is necassary because in CMUCL, only one subclass of +; standard-generic-function can be created, and taking away that option from user +; code doesn't make a lot of sense in our context. + +#-sbcl +(cl:defmethod reinitialize-instance :after + ((gf standard-generic-function) &rest initargs) + (declare (dynamic-extent initargs)) + (set-funcallable-instance-function + gf (compute-discriminating-function gf)) + #-cmu + (map-dependents + gf (lambda (dep) (apply #'update-dependent gf dep initargs)))) + +#-(or cmu sbcl) +(cl:defmethod add-method :after + ((gf standard-generic-function) method) + (map-dependents + gf (lambda (dep) (update-dependent gf dep 'add-method method)))) + +#-(or cmu sbcl) +(cl:defmethod remove-method :after + ((gf standard-generic-function) method) + (map-dependents + gf (lambda (dep) (update-dependent gf dep 'remove-method method)))) + +#+sbcl +(defun ensure-method (gf lambda-expression + &key (method-class (generic-function-method-class gf)) + (qualifiers ()) + (lambda-list (cadr lambda-expression)) + (specializers (required-args lambda-list (constantly (find-class 't))))) + (multiple-value-bind + (method-lambda method-args) + (make-method-lambda + gf (class-prototype method-class) + lambda-expression ()) + (let ((method (apply #'make-instance + method-class + :qualifiers qualifiers + :lambda-list lambda-list + :specializers specializers + :function (compile nil method-lambda) + method-args))) + (add-method gf method) + method))) + +#| +(defgeneric transform-specializer (specializer) + (:method (specializer) specializer) + (:method ((specializer class)) + (class-name specializer)) + (:method ((specializer eql-specializer)) + `(eql ,(eql-specializer-object specializer)))) +|# + +#-sbcl +(defun ensure-method (gf lambda-expression + &key (qualifiers ()) + (lambda-list (cadr lambda-expression)) + (specializers (required-args lambda-list (constantly 't)))) + (funcall (compile nil `(lambda () + (defmethod ,(generic-function-name gf) ,@qualifiers + ,(loop for specializer in specializers + for (arg . rest) on lambda-list + collect `(,arg ,specializer) into args + finally (return (nconc args rest))) + ,@(cddr lambda-expression)))))) + +;; The following ensures that effective slot definitions have a documentation in CMUCL. + +#+cmu +(defmethod compute-effective-slot-definition :around + ((class standard-class) name direct-slot-definitions) + (let ((effective-slot (call-next-method))) + (loop for direct-slot in direct-slot-definitions + for documentation = (documentation direct-slot 't) + when documentation do + (setf (documentation effective-slot 't) documentation) + (loop-finish)) + effective-slot)) + +;; The following can be used in direct-slot-definition-class to get the correct initargs +;; for a slot. Use it like this: +;; +;; (defmethod direct-slot-definition-class +;; ((class my-standard-class) &rest initargs) +;; (declare (dynamic-extent initargs)) +;; (destructuring-bind +;; (&key key-of-interest &allow-other-keys) +;; (fix-slot-initargs initargs) +;; ...)) + +(defvar *standard-slot-keys* + '(:name :documentation + :initargs :initform :initfunction + :readers :writers)) + +(defun fix-slot-initargs (initargs) + #+sbcl initargs + #+cmu + (let* ((counts (loop with counts + for (key nil) on initargs by #'cddr + do (incf (getf counts key 0)) + finally (return counts))) + (keys-to-fix (loop for (key value) on counts by #'cddr + if (> value 1) collect key))) + (if keys-to-fix + (let ((multiple-standard-keys + (intersection keys-to-fix *standard-slot-keys*))) + (if multiple-standard-keys + (error "Too many occurences of ~S in slot initargs ~S." + multiple-standard-keys initargs) + (loop with fixed-keys + for (key value) on initargs by #'cddr + if (member key keys-to-fix) + do (nconcf (getf fixed-keys key) (list value)) + else nconc (list key value) into fixed-initargs + finally (return (nconc fixed-initargs fixed-keys))))) + initargs))) + +;; In CMUCL, TYPEP and SUBTYPEP don't work as expected +;; in conjunction with class metaobjects. + +#-sbcl +(progn + (defgeneric typep (object type) + (:method (object type) + (cl:typep object type)) + (:method (object (type class)) + (cl:typep object (class-name type)))) + + (defgeneric subtypep (type1 type2) + (:method (type1 type2) + (cl:subtypep type1 type2)) + (:method ((type1 class) type2) + (cl:subtypep (class-name type1) type2)) + (:method (type1 (type2 class)) + (cl:subtypep type1 (class-name type2))) + (:method ((type1 class) (type2 class)) + (cl:subtypep (class-name type1) + (class-name type2))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew :closer-mop *features*))

Added: branches/trunk-reorg/thirdparty/closer-mop/release-notes.txt =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/release-notes.txt 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/release-notes.txt 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,34 @@ +Closer to MOP Release Note + +v0.0 initial release + +v0.1 +- separated single implementation into several ones, one for each MOP implementation / implementation family, in order to improve maintainability +- added support for LispWorks 4.4 +- removed extra method options from the LispWorks defmethod - it's a useful feature, but doesn't belong here +- the automatically generated slot accessor methods in LispWorks closed over the wrong slot names. fixed. (obsolete because of the next issue) +- In some cases, LispWorks deoptimizes slot access and reverts to the slot-value-using-class, etc., functions. This rendered the previously taken approach for fixing that protocol useless. Now, we have a much simpler fix. (Thanks to Jeff Caldwell.) Unfortunately, now some of the features that were previously fixed are missing again (correct initialization of accessor methods, accessor-method-slot-definition, reader-method-class and writer-method-class). Fortunately, LispWorks has already fixed those in 4.4, so this is no problem anymore in the long run. + +v0.2 +- The trick for reinitialization of generic-function-name or class-name in allegro, pcl, lispworks and mcl didn't work and had to be dropped. +- In clisp, defgeneric does call ensure-generic-function-using-class. This wasn't detected before due to a bug in mop-feature-tests. (Thanks to Bruno Haible.) +- Added the utility function ensure-method for programmatically creating methods, supported on all platforms. +- The defmethod macro for LispWorks didn't have an implicit block with the name of the generic function. Fixed. +- LispWorks 4.3 is not supported anymore. The existing conditionalizations are still available, though, and will be retained as long as they don't stand in the way of anything else. +- Since I have to override some symbols from the common-lisp package, I provide two utility packages closer-common-lisp and closer-common-lisp-user, similar to common-lisp and common-lisp-user but with all the MOP symbols added. The default packages additionally added by the various Common Lisp implementations are not added here. (I think that's cleaner.) +- Handling of pseudo-anonymous classes in CMU CL and SBCL had a copy&paste bug: The name was changed again in reinitialize-instance. +- TYPEP and SUBTYPEP don't work as expected in CMU CL and SBCL in conjunction with class metaobjects. Same for MCL, but for different reasons. So I have shadowed them and provide a new definition. (In CMU CL and SBCL, class metaobject are not considered types. In MCL, type information for class metaobjects is not available at some stages. Unfortunately, it doesn't seem to be possible to fix this with finalize-inheritance, so I have to revert to membership tests on the class precedence list.) +- MCL also doesn't like anonymous classes. So I have added a fix for that. +- I have incorrectly reported that MAKE-METHOD-LAMBDA is unreliable in CMU CL and SBCL. This was due to a bug in my test suite. However, it is required that the respective generic function and method metaobject classes and make-method-lambda definitions are part of the compilation environment when you want to use them. I have updated the respective sections in features.lisp and features.txt. +- Switched to an MIT/BSD-style license. + +v0.3 +- Now supports OpenMCL 1.0, LispWorks 4.4.6, SBCL 0.9.7 - 0.9.9, CMUCL 19C, Allegro 8.0, clisp 2.37 and 2.38. +- STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are now compatible in SBCL. This required some changes in the PCL support. +- Dropped the reports for LispWorks 4.3. +- Allegro 6.2 is not supported anymore. The existing conditionalizations are still available, though, and will be retained as long as they don't stand in the way of anything else. +- The incorrect specialization of slot-boundp-using-class and slot-makunbound-using-class on symbols instead of slot definition metaobjects in Allegro is fixed. +- SBCL 0.9.7 has improved a lot wrt MOP compatibility. This required some changes in the PCL support. +- The lack of extensible :allocation kinds in Allegro is fixed. (Covers 6.2, 7.0 and 8.0. Thanks to John Foderaro for giving me the important hint on how to solve this.) + +After version 0.3, there are no separate release notes anymore, but they will be generated automatically by darcs in the future.

Added: branches/trunk-reorg/thirdparty/closer-mop/supported-cls.txt =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/supported-cls.txt 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/supported-cls.txt 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,10 @@ +Allegro 7.0, 8.0 & 8.1 +CLisp 2.35 - 2.41 +CMU Common Lisp 19c, 19d +LispWorks 4.4.5, 4.4.6 Personal Edition +LispWorks 4.4.5, 4.4.6 Professional Edition +LispWorks 5.0, 5.0.1, Personal Edition +LispWorks 5.0 - 5.0.2, Professional Edition +Macintosh Common Lisp 5.1 +OpenMCL 1.0 +SBCL 0.9.16 - 0.9.18, 1.0.1 - 1.0.10

Added: branches/trunk-reorg/thirdparty/closer-mop/test/jeffs-code.lisp =================================================================== --- branches/trunk-reorg/thirdparty/closer-mop/test/jeffs-code.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/closer-mop/test/jeffs-code.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,207 @@ +;;; Jeff Caldwell 2004-04-16 +;;; LWL 4.3 +;;; +;;; To reproduce the issues I have come across: +;;; +;;; 1. (asdf:oos 'asdf:load-op 'closer-mop) +;;; 2. (compile-file "c2mop-attributes.lisp" :load t) +;;; 3. (in-package #:c2mop-test) +;;; C2MOP-TEST> (setq cr (make-instance 'credit-rating)) +;;; => Stack overflow (stack size 16000). +;;; +;;; (In this code, I accidently took out the format statements +;;; creating the output below. You may wish to put them back +;;; in the slot-value-using-class and (setf slot-value-using-class) +;;; methods at the bottom of this file.) +;;; +;;; slot-value-using-class class #<ATTRIBUTES-CLASS CREDIT-RATING 2134BF1C> +;;; object #<CREDIT-RATING 21732B2C> slot-name ALL-ATTRIBUTES-2382 +;;; slot-value-using-class class #<ATTRIBUTES-CLASS CREDIT-RATING 2134BF1C> +;;; object #<CREDIT-RATING 21732B2C> slot-name LEVEL +;;; slot-value-using-class class #<ATTRIBUTES-CLASS CREDIT-RATING 2134BF1C> +;;; object #<CREDIT-RATING 21732B2C> +;;; slot-name #<ATTRIBUTES-EFFECTIVE-SLOT-DEFINITION LEVEL 2134396C> +;;; slot-value-using-class class #<ATTRIBUTES-CLASS CREDIT-RATING 2134BF1C> +;;; object #<CREDIT-RATING 21732B2C> slot-name LEVEL +;;; slot-value-using-class class #<ATTRIBUTES-CLASS CREDIT-RATING 2134BF1C> +;;; object #<CREDIT-RATING 21732B2C> +;;; slot-name #<ATTRIBUTES-EFFECTIVE-SLOT-DEFINITION LEVEL 2134396C> +;;; slot-value-using-class class #<ATTRIBUTES-CLASS CREDIT-RATING 2134BF1C> +;;; object #<CREDIT-RATING 21732B2C> slot-name LEVEL +;;; slot-value-using-class class #<ATTRIBUTES-CLASS CREDIT-RATING 2134BF1C> +;;; object #<CREDIT-RATING 21732B2C> +;;; slot-name #<ATTRIBUTES-EFFECTIVE-SLOT-DEFINITION LEVEL 2134396C> +;;; ... +;;; +;;; Note that it alternates between slot-name LEVEL and +;;; slot-name #<ATTRIBUTES-EFFECTIVE-... +;;; +;;; In closer-mop.lisp change +;;; +;;; (cl:defmethod slot-value-using-class +;;; ((class standard-class) object (slot symbol)) +;;; (let ((slotd (find slot (class-slots class) :key #'slot-definition-name))) +;;; (if slotd +;;; (if (default-reader slotd) +;;; (slot-value-using-class class object slotd) +;;; (call-next-method)) +;;; (slot-missing class object slot 'slot-value)))) +;;; +;;; to +;;; +;;; ... +;;; (if slotd +;;; (if (default-reader slotd) +;;; (slot-value-using-class (find-class 'standard-class) +;;; object slotd) +;;; ... +;;; +;;; (I have no idea if that's a correct patch but it does stop +;;; the recursive stack overflow.) +;;; +;;; Then +;;; (asdf:oos 'asdf:load-op 'closer-mop) +;;; (setq cr (make-instance 'credit-rating) +;;; => +;;; The slot #<ATTRIBUTES-EFFECTIVE-SLOT-DEFINITION LEVEL 2133983C> is +;;; missing from #<CREDIT-RATING 206F0864> (of class #<ATTRIBUTES-CLASS +;;; CREDIT-RATING 2133B3DC>), when reading the value. +;;; +;;; At this point you also can remove the slot-value-using-class and +;;; setf slot-value-using-class methods. They were no-ops in this +;;; example, something I had run across in other code. I left them +;;; here to show the recursive stack overflow. Now that it is "fixed", +;;; we are left with the missing slot problem above. +;;; (The problem above is somewhat different from what I reported +;;; in my first email but the error above is what I'm getting now +;;; with this example.) +;;; +;;; Simply using the LW MOP, instead of using closer-mop, +;;; "fixes" the problem above. Quit using closer-mop and revert +;;; to the LW-only MOP. Change the defpackage to +;;; +;;; (defpackage #:c2mop-test +;;; (:use :cl :cl-user :clos)) +;;; +;;; (cl-user::quit) ;; Make really sure everything's fresh +;;; M-x slime +;;; (compile-file "c2mop-attributes.lisp" :load t) +;;; CL-USER> (in-package #:c2mop-test) +;;; #<PACKAGE C2MOP-TEST> +;;; C2MOP-TEST> (setq cr (make-instance 'credit-rating)) +;;; #<CREDIT-RATING 206EDFAC> +;;; C2MOP-TEST> (setf (level cr) 42) +;;; 42 +;;; C2MOP-TEST> (level cr) +;;; 42 +;;; C2MOP-TEST> (setf (slot-attribute cr 'level 'date-set) 20040416) +;;; 20040416 +;;; C2MOP-TEST> (slot-attribute cr 'level 'date-set) +;;; 20040416 +;;; + + +;;; +(defpackage #:c2mop-test +; (:use :cl :cl-user :clos) + (:use :cl :cl-user :closer-mop) + (:shadowing-import-from :closer-mop + #:defclass #:defmethod #:standard-class + #:ensure-generic-function #:defgeneric + #:standard-generic-function #:class-name) +) + +(in-package #:c2mop-test) + +(eval-when (:compile-toplevel :load-toplevel :execute) + +(defvar *all-attributes* (gensym "ALL-ATTRIBUTES-")) +(defvar *current-direct-slot-definitions* nil) + +(defclass attributes-class (standard-class) ()) + +(defclass attributes-mixin + (standard-slot-definition) + ((attributes :initarg :attributes :accessor slot-definition-attributes + :initform nil))) + +(defclass attributes-direct-slot-definition + (standard-direct-slot-definition attributes-mixin) + ()) + +(defclass attributes-effective-slot-definition + (standard-effective-slot-definition attributes-mixin) + ()) + +(defmethod effective-slot-definition-class ((class attributes-class) + &rest initargs) + (find-class 'attributes-effective-slot-definition)) + +(defmethod compute-effective-slot-definition ((class attributes-class) + name direct-slots) + (let* ((normal-slot (call-next-method))) + (setf (slot-definition-attributes normal-slot) + (remove-duplicates + (apply #'append (mapcar #'slot-definition-attributes + direct-slots)))) + normal-slot)) + +(defmethod direct-slot-definition-class + ((class attributes-class) &rest initargs) + (find-class 'attributes-direct-slot-definition)) + +(defmethod process-a-slot-option + ((class attributes-class) option value + already-processed-options slot) + (princ "process-a-slot-option") (princ option) + (if (eq option :attributes) + (list* :attributes `',value already-processed-options) + (call-next-method))) + +(defmethod compute-slots ((class attributes-class)) + (let* ((normal-slots (call-next-method)) + (alist (mapcar (lambda (slot) + (cons (slot-definition-name slot) + (mapcar (lambda (attr) (cons attr nil)) + (slot-definition-attributes + slot)))) + normal-slots))) + (cons (make-instance 'attributes-effective-slot-definition + :name *all-attributes* + :initform alist + :initfunction (lambda () alist)) + normal-slots))) + +(defun slot-attribute (instance slot-name attribute) + (cdr (slot-attribute-bucket instance slot-name attribute))) + +(defun (setf slot-attribute) (new-value instance slot-name attribute) + (setf (cdr (slot-attribute-bucket instance slot-name attribute)) + new-value)) + +(defun slot-attribute-bucket (instance slot-name attribute) + (let* ((all-buckets (slot-value instance *all-attributes*)) + (slot-bucket (assoc slot-name all-buckets))) + (unless slot-bucket + (error "Slot ~S of ~S has no attributes." + slot-name instance)) + (let ((attr-bucket (assoc attribute (cdr slot-bucket)))) + (unless attr-bucket + (error "Slot ~S of ~S has no attribute ~S." + slot-name instance attribute)) + attr-bucket))) + +(defmethod clos:slot-value-using-class + ((class attributes-class) object (slot-name attributes-effective-slot-definition)) + (call-next-method)) + +(defmethod (setf clos:slot-value-using-class) + (value (class attributes-class) object (slot-name attributes-effective-slot-definition)) + (call-next-method)) + +) ; eval-when + +(defclass credit-rating () + ((level :attributes (date-set time-set) :accessor level) + (desc :accessor desc)) + (:metaclass attributes-class))

Added: branches/trunk-reorg/thirdparty/lw-compat/_darcs/current/lw-compat-package.lisp =================================================================== --- branches/trunk-reorg/thirdparty/lw-compat/_darcs/current/lw-compat-package.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/lw-compat/_darcs/current/lw-compat-package.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,7 @@ +(in-package :cl-user) + +#-lispworks +(defpackage #:lispworks + (:use #:common-lisp) + (:export #:appendf #:nconcf #:rebinding #:removef + #:when-let #:when-let* #:with-unique-names))

Added: branches/trunk-reorg/thirdparty/lw-compat/_darcs/current/lw-compat.asd =================================================================== --- branches/trunk-reorg/thirdparty/lw-compat/_darcs/current/lw-compat.asd 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/lw-compat/_darcs/current/lw-compat.asd 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,34 @@ +(asdf:defsystem #:lw-compat + :name "LispWorks Compatibility Library" + :author "Pascal Costanza, with permission from http://www.lispworks.com" + :version "0.22" + :licence " +Copyright (c) 2005, 2006 Pascal Costanza +with permission from http://www.lispworks.com + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, sublicense, and/or +sell copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. +" + :components (#-lispworks + (:file "lw-compat-package") + #-lispworks + (:file "lw-compat" + :depends-on ("lw-compat-package"))))

Added: branches/trunk-reorg/thirdparty/lw-compat/_darcs/current/lw-compat.lisp =================================================================== --- branches/trunk-reorg/thirdparty/lw-compat/_darcs/current/lw-compat.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/lw-compat/_darcs/current/lw-compat.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,50 @@ +(in-package #:lispworks) + +#+lispworks +(eval-when (:compile-toplevel :load-toplevel :execute) + (error "lw-compat is not needed in LispWorks.")) + +(define-modify-macro appendf (&rest lists) + append "Appends lists to the end of given list.") + +(define-modify-macro nconcf (&rest lists) + nconc "Appends lists to the end of given list by NCONC.") + +(defmacro rebinding (vars &body body) + "Ensures unique names for all the variables in a groups of forms." + (loop for var in vars + for name = (gensym (symbol-name var)) + collect `(,name ,var) into renames + collect ``(,,var ,,name) into temps + finally (return `(let ,renames + (with-unique-names + ,vars + `(let (,,@temps) + ,,@body)))))) + +(define-modify-macro removef (item &rest keys) + (lambda (place item &rest keys &key test test-not start end key) + (declare (ignorable test test-not start end key)) + (apply #'remove item place keys)) + "Removes an item from a sequence.") + +(defmacro when-let ((var form) &body body) + "Executes a body of code if a form evaluates to non-nil, + propagating the result of the form through the body of code." + `(let ((,var ,form)) + (when ,var + (locally + ,@body)))) + +(defmacro when-let* (bindings &body body) + "Executes a body of code if a series of forms evaluates to non-nil, + propagating the results of the forms through the body of code." + (loop for form = `(progn ,@body) then `(when-let (,(car binding) ,(cadr binding)) ,form) + for binding in (reverse bindings) + finally (return form))) + +(defmacro with-unique-names (names &body body) + "Returns a body of code with each specified name bound to a similar name." + `(let ,(mapcar (lambda (name) `(,name (gensym ,(symbol-name name)))) + names) + ,@body))

Added: branches/trunk-reorg/thirdparty/lw-compat/_darcs/inventories/20060826123920-dccf3-4b37fa484f969eb9c3837a020e32b42e33f4cef6.gz =================================================================== --- branches/trunk-reorg/thirdparty/lw-compat/_darcs/inventories/20060826123920-dccf3-4b37fa484f969eb9c3837a020e32b42e33f4cef6.gz 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/lw-compat/_darcs/inventories/20060826123920-dccf3-4b37fa484f969eb9c3837a020e32b42e33f4cef6.gz 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,8 @@ +[Initial revision (v0.2). +pc@p-cos.net**20050802152818] +[Added licensing information. +pc@p-cos.net**20050811150118] +[Replaced a reduce idiom with a better understandable loop idiom. +pc@p-cos.net**20051228220551] +[Removed a spurious in-package declaration in the .asd file. +pc@p-cos.net**20060821203626] \ No newline at end of file

Added: branches/trunk-reorg/thirdparty/lw-compat/_darcs/inventory =================================================================== --- branches/trunk-reorg/thirdparty/lw-compat/_darcs/inventory 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/lw-compat/_darcs/inventory 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,7 @@ +Starting with tag: +[TAG 0.22 +pc@p-cos.net**20060826123920] +[Updated version number in the .asd file. +pc@p-cos.net**20060826125726] +[Updated copyright information. +pc@p-cos.net**20060918174843] \ No newline at end of file

Added: branches/trunk-reorg/thirdparty/lw-compat/_darcs/patches/20050802152818-dccf3-9ba8553d2b62c698e6208680ab099ea6273a7458.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/lw-compat/_darcs/patches/20050802152818-dccf3-9ba8553d2b62c698e6208680ab099ea6273a7458.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/lw-compat/_darcs/patches/20050811150118-dccf3-9db8fc99fbfbac77dda86fa3ca80f0f92c0f054b.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/lw-compat/_darcs/patches/20050811150118-dccf3-9db8fc99fbfbac77dda86fa3ca80f0f92c0f054b.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/lw-compat/_darcs/patches/20051228220551-dccf3-bec704780b86cf94b4f443e53d52d8e46f8ab139.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/lw-compat/_darcs/patches/20051228220551-dccf3-bec704780b86cf94b4f443e53d52d8e46f8ab139.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/lw-compat/_darcs/patches/20060821203626-dccf3-a75c8e2b513b571a43ce6c5e8dd377b2bca40887.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/lw-compat/_darcs/patches/20060821203626-dccf3-a75c8e2b513b571a43ce6c5e8dd377b2bca40887.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/lw-compat/_darcs/patches/20060826123920-dccf3-4b37fa484f969eb9c3837a020e32b42e33f4cef6.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/lw-compat/_darcs/patches/20060826123920-dccf3-4b37fa484f969eb9c3837a020e32b42e33f4cef6.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/lw-compat/_darcs/patches/20060826125726-dccf3-b9ca9d92f93eefe4744f2275eaf40b6702e5b743.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/lw-compat/_darcs/patches/20060826125726-dccf3-b9ca9d92f93eefe4744f2275eaf40b6702e5b743.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/lw-compat/_darcs/patches/20060918174843-dccf3-641503d97f1447c7cf67b79d9d0e557fe35e4dfa.gz =================================================================== (Binary files differ)

Property changes on: branches/trunk-reorg/thirdparty/lw-compat/_darcs/patches/20060918174843-dccf3-641503d97f1447c7cf67b79d9d0e557fe35e4dfa.gz ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

Added: branches/trunk-reorg/thirdparty/lw-compat/_darcs/prefs/binaries =================================================================== --- branches/trunk-reorg/thirdparty/lw-compat/_darcs/prefs/binaries 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/lw-compat/_darcs/prefs/binaries 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,39 @@ +# Binary file regexps: +.png$ +.PNG$ +.gz$ +.GZ$ +.pdf$ +.PDF$ +.jpg$ +.JPG$ +.gif$ +.GIF$ +.tar$ +.TAR$ +.bz2$ +.BZ2$ +.z$ +.Z$ +.zip$ +.ZIP$ +.jar$ +.JAR$ +.so$ +.SO$ +.a$ +.A$ +.tgz$ +.TGZ$ +.jpeg$ +.JPEG$ +.mpg$ +.MPG$ +.mpeg$ +.MPEG$ +.iso$ +.ISO$ +.exe$ +.EXE$ +.doc$ +.DOC$

Added: branches/trunk-reorg/thirdparty/lw-compat/_darcs/prefs/boring =================================================================== --- branches/trunk-reorg/thirdparty/lw-compat/_darcs/prefs/boring 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/lw-compat/_darcs/prefs/boring 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,34 @@ +# Boring file regexps: +.hi$ +.o$ +.o.cmd$ +# *.ko files aren't boring by default because they might +# be Korean translations rather than kernel modules. +# .ko$ +.ko.cmd$ +.mod.c$ +(^|/).tmp_versions($|/) +(^|/)CVS($|/) +(^|/)RCS($|/) +~$ +#(^|/).[^/] +(^|/)_darcs($|/) +.bak$ +.BAK$ +.orig$ +(^|/)vssver.scc$ +.swp$ +(^|/)MT($|/) +(^|/){arch}($|/) +(^|/).arch-ids($|/) +(^|/), +.class$ +.prof$ +(^|/).DS_Store$ +(^|/)BitKeeper($|/) +(^|/)ChangeSet($|/) +(^|/).svn($|/) +.py[co]$ +# +.cvsignore$ +(^|/)Thumbs.db$

Added: branches/trunk-reorg/thirdparty/lw-compat/_darcs/prefs/defaultrepo =================================================================== --- branches/trunk-reorg/thirdparty/lw-compat/_darcs/prefs/defaultrepo 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/lw-compat/_darcs/prefs/defaultrepo 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1 @@ +http://common-lisp.net/project/closer/repos/lw-compat

Added: branches/trunk-reorg/thirdparty/lw-compat/_darcs/prefs/motd ===================================================================

Added: branches/trunk-reorg/thirdparty/lw-compat/_darcs/prefs/repos =================================================================== --- branches/trunk-reorg/thirdparty/lw-compat/_darcs/prefs/repos 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/lw-compat/_darcs/prefs/repos 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1 @@ +http://common-lisp.net/project/closer/repos/lw-compat

Added: branches/trunk-reorg/thirdparty/lw-compat/lw-compat-package.lisp =================================================================== --- branches/trunk-reorg/thirdparty/lw-compat/lw-compat-package.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/lw-compat/lw-compat-package.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,7 @@ +(in-package :cl-user) + +#-lispworks +(defpackage #:lispworks + (:use #:common-lisp) + (:export #:appendf #:nconcf #:rebinding #:removef + #:when-let #:when-let* #:with-unique-names))

Added: branches/trunk-reorg/thirdparty/lw-compat/lw-compat.asd =================================================================== --- branches/trunk-reorg/thirdparty/lw-compat/lw-compat.asd 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/lw-compat/lw-compat.asd 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,34 @@ +(asdf:defsystem #:lw-compat + :name "LispWorks Compatibility Library" + :author "Pascal Costanza, with permission from http://www.lispworks.com" + :version "0.22" + :licence " +Copyright (c) 2005, 2006 Pascal Costanza +with permission from http://www.lispworks.com + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, sublicense, and/or +sell copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. +" + :components (#-lispworks + (:file "lw-compat-package") + #-lispworks + (:file "lw-compat" + :depends-on ("lw-compat-package"))))

Added: branches/trunk-reorg/thirdparty/lw-compat/lw-compat.lisp =================================================================== --- branches/trunk-reorg/thirdparty/lw-compat/lw-compat.lisp 2007-10-04 19:49:06 UTC (rev 2206) +++ branches/trunk-reorg/thirdparty/lw-compat/lw-compat.lisp 2007-10-04 19:56:01 UTC (rev 2207) @@ -0,0 +1,50 @@ +(in-package #:lispworks) + +#+lispworks +(eval-when (:compile-toplevel :load-toplevel :execute) + (error "lw-compat is not needed in LispWorks.")) + +(define-modify-macro appendf (&rest lists) + append "Appends lists to the end of given list.") + +(define-modify-macro nconcf (&rest lists) + nconc "Appends lists to the end of given list by NCONC.") + +(defmacro rebinding (vars &body body) + "Ensures unique names for all the variables in a groups of forms." + (loop for var in vars + for name = (gensym (symbol-name var)) + collect `(,name ,var) into renames + collect ``(,,var ,,name) into temps + finally (return `(let ,renames + (with-unique-names + ,vars + `(let (,,@temps) + ,,@body)))))) + +(define-modify-macro removef (item &rest keys) + (lambda (place item &rest keys &key test test-not start end key) + (declare (ignorable test test-not start end key)) + (apply #'remove item place keys)) + "Removes an item from a sequence.") + +(defmacro when-let ((var form) &body body) + "Executes a body of code if a form evaluates to non-nil, + propagating the result of the form through the body of code." + `(let ((,var ,form)) + (when ,var + (locally + ,@body)))) + +(defmacro when-let* (bindings &body body) + "Executes a body of code if a series of forms evaluates to non-nil, + propagating the results of the forms through the body of code." + (loop for form = `(progn ,@body) then `(when-let (,(car binding) ,(cadr binding)) ,form) + for binding in (reverse bindings) + finally (return form))) + +(defmacro with-unique-names (names &body body) + "Returns a body of code with each specified name bound to a similar name." + `(let ,(mapcar (lambda (name) `(,name (gensym ,(symbol-name name)))) + names) + ,@body))