From ehuelsmann at common-lisp.net Wed Aug 1 10:39:09 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Wed, 01 Aug 2012 03:39:09 -0700 Subject: [armedbear-cvs] r14035 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Aug 1 03:39:07 2012 New Revision: 14035 Log: Fix #226 (Invocation of an undefined function in a fresh ABCL crashes): make sure the PRINT-OBJECT generic function exists before defining methods on it. Modified: trunk/abcl/src/org/armedbear/lisp/format.lisp Modified: trunk/abcl/src/org/armedbear/lisp/format.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/format.lisp Tue Jul 31 11:17:01 2012 (r14034) +++ trunk/abcl/src/org/armedbear/lisp/format.lisp Wed Aug 1 03:39:07 2012 (r14035) @@ -33,6 +33,8 @@ (in-package "SYSTEM") +(require "PRINT-OBJECT") + ;;; From primordial-extensions.lisp. ;;; Concatenate together the names of some strings and symbols, From ehuelsmann at common-lisp.net Wed Aug 1 11:53:37 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Wed, 01 Aug 2012 04:53:37 -0700 Subject: [armedbear-cvs] r14036 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Aug 1 04:53:36 2012 New Revision: 14036 Log: Re #226: Automatically generate autoloads. This commit adds the auto generation code and infrastructure. Next steps include clean up of autoloads.lisp, deciding how to handle symbols in multiple files and SETF functions/expanders. Added: trunk/abcl/src/org/armedbear/lisp/autoloads-gen.lisp Modified: trunk/abcl/src/org/armedbear/lisp/boot.lisp trunk/abcl/src/org/armedbear/lisp/compile-system.lisp trunk/abcl/src/org/armedbear/lisp/setf.lisp Added: trunk/abcl/src/org/armedbear/lisp/autoloads-gen.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/src/org/armedbear/lisp/autoloads-gen.lisp Wed Aug 1 04:53:36 2012 (r14036) @@ -0,0 +1,62 @@ + +;; This is a bootstrapping file +;; We need a file in place before starting compilation, because +;; 'autoloads.lisp' only contains the manual additions. + +;; The content has been generated using the same code as the code which +;; is used at build-time. However, this file has been tweaked to allow +;; the ant target to load its files without problems. + +;; Generation of an file up-to-date file is part of the build process +;; and that file is included in abcl.jar. + +(IN-PACKAGE :FORMAT) +(DOLIST (SYSTEM::FS (QUOTE ((("format") %PRINT-FORMAT-ERROR MISSING-ARG MAKE-FORMAT-DIRECTIVE FORMAT-DIRECTIVE-P TOKENIZE-CONTROL-STRING PARSE-DIRECTIVE %FORMATTER EXPAND-CONTROL-STRING EXPAND-DIRECTIVE-LIST EXPAND-DIRECTIVE EXPAND-NEXT-ARG %SET-FORMAT-DIRECTIVE-EXPANDER %SET-FORMAT-DIRECTIVE-INTERPRETER FIND-DIRECTIVE A-FORMAT-DIRECTIVE-EXPANDER S-FORMAT-DIRECTIVE-EXPANDER C-FORMAT-DIRECTIVE-EXPANDER W-FORMAT-DIRECTIVE-EXPANDER EXPAND-FORMAT-INTEGER D-FORMAT-DIRECTIVE-EXPANDER B-FORMAT-DIRECTIVE-EXPANDER O-FORMAT-DIRECTIVE-EXPANDER X-FORMAT-DIRECTIVE-EXPANDER R-FORMAT-DIRECTIVE-EXPANDER P-FORMAT-DIRECTIVE-EXPANDER F-FORMAT-DIRECTIVE-EXPANDER E-FORMAT-DIRECTIVE-EXPANDER G-FORMAT-DIRECTIVE-EXPANDER $-FORMAT-DIRECTIVE-EXPANDER %-FORMAT-DIRECTIVE-EXPANDER &-FORMAT-DIRECTIVE-EXPANDER |\|-FORMAT-DIRECTIVE-EXPANDER| ~-FORMAT-DIRECTIVE-EXPANDER |Newline-FORMAT-DIRECTIVE-EXPANDER| T-FORMAT-DIRECTIVE-EXPANDER _-FORMAT-DIRECTIVE-EXPANDER I-FORMAT-DIRECTIVE-EXPANDER *-FORMAT-DIRECTIVE-EXPANDER ?-FORMAT-DIRECTIVE-EXPANDER |(-FORMAT-DIRECTIVE-EXPANDER| |)-FORMAT-DIRECTIVE-EXPANDER| [-FORMAT-DIRECTIVE-EXPANDER PARSE-CONDITIONAL-DIRECTIVE EXPAND-MAYBE-CONDITIONAL EXPAND-TRUE-FALSE-CONDITIONAL |;-FORMAT-DIRECTIVE-EXPANDER| ]-FORMAT-DIRECTIVE-EXPANDER ^-FORMAT-DIRECTIVE-EXPANDER {-FORMAT-DIRECTIVE-EXPANDER }-FORMAT-DIRECTIVE-EXPANDER ILLEGAL-INSIDE-JUSTIFICATION-P <-FORMAT-DIRECTIVE-EXPANDER >-FORMAT-DIRECTIVE-EXPANDER PARSE-FORMAT-LOGICAL-BLOCK ADD-FILL-STYLE-NEWLINES ADD-FILL-STYLE-NEWLINES-AUX PARSE-FORMAT-JUSTIFICATION EXPAND-FORMAT-LOGICAL-BLOCK EXPAND-FORMAT-JUSTIFICATION /-FORMAT-DIRECTIVE-EXPANDER EXTRACT-USER-FUN-NAME %COMPILER-WALK-FORMAT-STRING %FORMAT INTERPRET-DIRECTIVE-LIST FORMAT-WRITE-FIELD FORMAT-PRINC A-FORMAT-DIRECTIVE-INTERPRETER FORMAT-PRIN1 S-FORMAT-DIRECTIVE-INTERPRETER C-FORMAT-DIRECTIVE-INTERPRETER FORMAT-PRINT-NAMED-CHARACTER W-FORMAT-DIRECTIVE-INTERPRETER FORMAT-PRINT-INTEGER FORMAT-ADD-COMMAS D-FORMAT-DIRECTIVE-INTERPRETER B-FORMAT-DIRECTIVE-INTERPRETER O-FORMAT-DIRECTIVE-INTERPRETER X-FORMAT-DIRECTIVE-INTERPRETER R-FORMAT-DIRECTIVE-INTERPRETER FORMAT-PRINT-SMALL-CARDINAL FORMAT-PRINT-CARDINAL FORMAT-PRINT-CARDINAL-AUX FORMAT-PRINT-ORDINAL FORMAT-PRINT-OLD-ROMAN FORMAT-PRINT-ROMAN P-FORMAT-DIRECTIVE-INTERPRETER DECIMAL-STRING F-FORMAT-DIRECTIVE-INTERPRETER FORMAT-FIXED FORMAT-FIXED-AUX E-FORMAT-DIRECTIVE-INTERPRETER FORMAT-EXPONENTIAL FORMAT-EXPONENT-MARKER FORMAT-EXP-AUX G-FORMAT-DIRECTIVE-INTERPRETER FORMAT-GENERAL FORMAT-GENERAL-AUX $-FORMAT-DIRECTIVE-INTERPRETER FORMAT-DOLLARS %-FORMAT-DIRECTIVE-INTERPRETER &-FORMAT-DIRECTIVE-INTERPRETER |\|-FORMAT-DIRECTIVE-INTERPRETER| ~-FORMAT-DIRECTIVE-INTERPRETER |Newline-FORMAT-DIRECTIVE-INTERPRETER| T-FORMAT-DIRECTIVE-INTERPRETER OUTPUT-SPACES FORMAT-RELATIVE-TAB FORMAT-ABSOLUTE-TAB _-FORMAT-DIRECTIVE-INTERPRETER I-FORMAT-DIRECTIVE-INTERPRETER *-FORMAT-DIRECTIVE-INTERPRETER ?-FORMAT-DIRECTIVE-INTERPRETER |(-FORMAT-DIRECTIVE-INTERPRETER| |)-FORMAT-DIRECTIVE-INTERPRETER| [-FORMAT-DIRECTIVE-INTERPRETER |;-FORMAT-DIRECTIVE-INTERPRETER| ]-FORMAT-DIRECTIVE-INTERPRETER ^-FORMAT-DIRECTIVE-INTERPRETER {-FORMAT-DIRECTIVE-INTERPRETER }-FORMAT-DIRECTIVE-INTERPRETER <-FORMAT-DIRECTIVE-INTERPRETER INTERPRET-FORMAT-JUSTIFICATION FORMAT-JUSTIFICATION INTERPRET-FORMAT-LOGICAL-BLOCK /-FORMAT-DIRECTIVE-INTERPRETER)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(IN-PACKAGE :FORMAT) +(DOLIST (SYSTEM::FS (QUOTE ((("format") EXPANDER-NEXT-ARG EXPAND-BIND-DEFAULTS DEF-COMPLEX-FORMAT-DIRECTIVE DEF-FORMAT-DIRECTIVE EXPANDER-PPRINT-NEXT-ARG INTERPRET-FORMAT-INTEGER)))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(IN-PACKAGE :SEQUENCE) +(DOLIST (SYSTEM::FS (QUOTE ( ))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(IN-PACKAGE :SEQUENCE) +(DOLIST (SYSTEM::FS (QUOTE ( ))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(IN-PACKAGE :LOOP) +(DOLIST (SYSTEM::FS (QUOTE ((("loop") MAKE-LOOP-MINIMAX-INTERNAL MAKE-LOOP-MINIMAX LOOP-NOTE-MINIMAX-OPERATION LOOP-TEQUAL LOOP-TASSOC LOOP-TMEMBER LOOP-LOOKUP-KEYWORD MAKE-LOOP-UNIVERSE MAKE-STANDARD-LOOP-UNIVERSE LOOP-MAKE-PSETQ LOOP-MAKE-DESETQ LOOP-CONSTANT-FOLD-IF-POSSIBLE LOOP-CONSTANTP LOOP-CODE-DUPLICATION-THRESHOLD DUPLICATABLE-CODE-P DESTRUCTURING-SIZE ESTIMATE-CODE-SIZE ESTIMATE-CODE-SIZE-1 LOOP-CONTEXT LOOP-ERROR LOOP-WARN LOOP-CHECK-DATA-TYPE SUBST-GENSYMS-FOR-NIL LOOP-BUILD-DESTRUCTURING-BINDINGS LOOP-TRANSLATE LOOP-ITERATION-DRIVER LOOP-POP-SOURCE LOOP-GET-FORM LOOP-GET-COMPOUND-FORM LOOP-GET-PROGN LOOP-CONSTRUCT-RETURN LOOP-PSEUDO-BODY LOOP-EMIT-BODY LOOP-EMIT-FINAL-VALUE LOOP-DISALLOW-CONDITIONAL LOOP-DISALLOW-ANONYMOUS-COLLECTORS LOOP-DISALLOW-AGGREGATE-BOOLEANS LOOP-TYPED-INIT LOOP-OPTIONAL-TYPE LOOP-BIND-BLOCK LOOP-VAR-P LOOP-MAKE-VAR LOOP-MAKE-ITERATION-VAR LOOP-DECLARE-VAR LOOP-MAYBE-BIND-FORM LOOP-DO-IF LOOP-DO-INITIALLY LOOP-DO-FINALLY LOOP-DO-DO LOOP-DO-NAMED LOOP-DO-RETURN MAKE-LOOP-COLLECTOR LOOP-GET-COLLECTION-INFO LOOP-LIST-COLLECTION LOOP-SUM-COLLECTION LOOP-MAXMIN-COLLECTION LOOP-DO-ALWAYS LOOP-DO-THEREIS LOOP-DO-WHILE LOOP-DO-REPEAT LOOP-DO-WITH LOOP-HACK-ITERATION LOOP-DO-FOR LOOP-WHEN-IT-VAR LOOP-ANSI-FOR-EQUALS LOOP-FOR-ACROSS LOOP-LIST-STEP LOOP-FOR-ON LOOP-FOR-IN MAKE-LOOP-PATH ADD-LOOP-PATH LOOP-FOR-BEING LOOP-NAMED-VAR LOOP-COLLECT-PREPOSITIONAL-PHRASES LOOP-SEQUENCER LOOP-FOR-ARITHMETIC LOOP-SEQUENCE-ELEMENTS-PATH LOOP-HASH-TABLE-ITERATION-PATH LOOP-PACKAGE-SYMBOLS-ITERATION-PATH MAKE-ANSI-LOOP-UNIVERSE LOOP-STANDARD-EXPANSION)))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(IN-PACKAGE :LOOP) +(DOLIST (SYSTEM::FS (QUOTE ((("loop") WITH-LOOP-LIST-COLLECTION-HEAD LOOP-COLLECT-RPLACD LOOP-COLLECT-ANSWER WITH-MINIMAX-VALUE LOOP-ACCUMULATE-MINIMAX-VALUE LOOP-STORE-TABLE-DATA LOOP-REALLY-DESETQ LOOP-BODY LOOP-DESTRUCTURING-BIND)))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(IN-PACKAGE :MOP) +(DOLIST (SYSTEM::FS (QUOTE ((("clos") CLASS-SLOTS CLASS-DIRECT-SLOTS CLASS-LAYOUT CLASS-DIRECT-SUPERCLASSES CLASS-DIRECT-SUBCLASSES CLASS-DIRECT-METHODS CLASS-PRECEDENCE-LIST CLASS-FINALIZED-P CLASS-DEFAULT-INITARGS CLASS-DIRECT-DEFAULT-INITARGS ADD-DIRECT-SUBCLASS REMOVE-DIRECT-SUBCLASS FIXUP-STANDARD-CLASS-HIERARCHY MAP-DEPENDENTS MAPAPPEND MAPPLIST FUNCALLABLE-STANDARD-INSTANCE-ACCESS CANONICALIZE-DIRECT-SLOTS CANONICALIZE-DIRECT-SLOT MAYBE-NOTE-NAME-DEFINED CANONICALIZE-DEFCLASS-OPTIONS CANONICALIZE-DEFCLASS-OPTION MAKE-INITFUNCTION SLOT-DEFINITION-ALLOCATION SLOT-DEFINITION-INITARGS SLOT-DEFINITION-INITFORM SLOT-DEFINITION-INITFUNCTION SLOT-DEFINITION-NAME SLOT-DEFINITION-READERS SLOT-DEFINITION-WRITERS SLOT-DEFINITION-ALLOCATION-CLASS SLOT-DEFINITION-LOCATION SLOT-DEFINITION-TYPE SLOT-DEFINITION-DOCUMENTATION INIT-SLOT-DEFINITION DIRECT-SLOT-DEFINITION-CLASS MAKE-DIRECT-SLOT-DEFINITION EFFECTIVE-SLOT-DEFINITION-CLASS MAKE-EFFECTIVE-SLOT-DEFINITION COMPUTE-DEFAULT-INITARGS STD-COMPUTE-DEFAULT-INITARGS STD-FINALIZE-INHERITANCE FINALIZE-INHERITANCE STD-COMPUTE-CLASS-PRECEDENCE-LIST TOPOLOGICAL-SORT STD-TIE-BREAKER-RULE COLLECT-SUPERCLASSES* LOCAL-PRECEDENCE-ORDERING STD-COMPUTE-SLOTS STD-COMPUTE-EFFECTIVE-SLOT-DEFINITION FIND-SLOT-DEFINITION SLOT-LOCATION INSTANCE-SLOT-LOCATION %SET-SLOT-VALUE STD-SLOT-MAKUNBOUND STD-SLOT-EXISTS-P INSTANCE-SLOT-P STD-ALLOCATE-INSTANCE ALLOCATE-FUNCALLABLE-INSTANCE CLASS-PROTOTYPE MAYBE-FINALIZE-CLASS-SUBTREE MAKE-INSTANCE-STANDARD-CLASS STD-AFTER-INITIALIZATION-FOR-CLASSES EXPAND-LONG-DEFCOMBIN %MAKE-LONG-METHOD-COMBINATION METHOD-COMBINATION-NAME METHOD-COMBINATION-DOCUMENTATION SHORT-METHOD-COMBINATION-OPERATOR SHORT-METHOD-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT LONG-METHOD-COMBINATION-LAMBDA-LIST LONG-METHOD-COMBINATION-METHOD-GROUP-SPECS LONG-METHOD-COMBINATION-ARGS-LAMBDA-LIST LONG-METHOD-COMBINATION-GENERIC-FUNCTION-SYMBOL LONG-METHOD-COMBINATION-FUNCTION LONG-METHOD-COMBINATION-ARGUMENTS LONG-METHOD-COMBINATION-DECLARATIONS LONG-METHOD-COMBINATION-FORMS EXPAND-SHORT-DEFCOMBIN METHOD-GROUP-P CHECK-VARIABLE-NAME CANONICALIZE-METHOD-GROUP-SPEC EXTRACT-REQUIRED-PART EXTRACT-SPECIFIED-PART EXTRACT-OPTIONAL-PART PARSE-DEFINE-METHOD-COMBINATION-ARGUMENTS-LAMBDA-LIST WRAP-WITH-CALL-METHOD-MACRO ASSERT-UNAMBIGUOUS-METHOD-SORTING METHOD-COMBINATION-TYPE-LAMBDA DECLARATIONP LONG-FORM-METHOD-COMBINATION-ARGS DEFINE-LONG-FORM-METHOD-COMBINATION STD-FIND-METHOD-COMBINATION FIND-METHOD-COMBINATION INTERN-EQL-SPECIALIZER EQL-SPECIALIZER-OBJECT STD-METHOD-FUNCTION STD-METHOD-GENERIC-FUNCTION STD-METHOD-SPECIALIZERS STD-METHOD-QUALIFIERS STD-ACCESSOR-METHOD-SLOT-DEFINITION STD-METHOD-FAST-FUNCTION STD-FUNCTION-KEYWORDS METHOD-GENERIC-FUNCTION METHOD-FUNCTION METHOD-SPECIALIZERS GENERIC-FUNCTION-NAME GENERIC-FUNCTION-LAMBDA-LIST GENERIC-FUNCTION-METHODS GENERIC-FUNCTION-METHOD-CLASS GENERIC-FUNCTION-METHOD-COMBINATION GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER CLASSES-TO-EMF-TABLE METHOD-DOCUMENTATION CANONICALIZE-DEFGENERIC-OPTIONS CANONICALIZE-DEFGENERIC-OPTION ARGUMENT-PRECEDENCE-ORDER-INDICES FIND-GENERIC-FUNCTION LAMBDA-LISTS-CONGRUENT-P COLLECT-EQL-SPECIALIZER-OBJECTS FINALIZE-STANDARD-GENERIC-FUNCTION MAKE-INSTANCE-STANDARD-GENERIC-FUNCTION CANONICALIZE-SPECIALIZERS CANONICALIZE-SPECIALIZER PARSE-DEFMETHOD REQUIRED-PORTION EXTRACT-LAMBDA-LIST EXTRACT-SPECIALIZER-NAMES GET-KEYWORD-FROM-ARG ANALYZE-LAMBDA-LIST CHECK-METHOD-LAMBDA-LIST CHECK-ARGUMENT-PRECEDENCE-ORDER ENSURE-METHOD MAKE-INSTANCE-STANDARD-METHOD ADD-DIRECT-METHOD REMOVE-DIRECT-METHOD STD-ADD-METHOD STD-REMOVE-METHOD %FIND-METHOD FAST-CALLABLE-P SLOW-READER-LOOKUP STD-COMPUTE-DISCRIMINATING-FUNCTION SORT-METHODS METHOD-APPLICABLE-P STD-COMPUTE-APPLICABLE-METHODS METHOD-APPLICABLE-USING-CLASSES-P CHECK-APPLICABLE-METHOD-KEYWORD-ARGS COMPUTE-APPLICABLE-KEYWORDS WRAP-EMFUN-FOR-KEYWORD-ARGS-CHECK SLOW-METHOD-LOOKUP SLOW-METHOD-LOOKUP-1 SUB-SPECIALIZER-P STD-METHOD-MORE-SPECIFIC-P PRIMARY-METHOD-P BEFORE-METHOD-P AFTER-METHOD-P AROUND-METHOD-P PROCESS-NEXT-METHOD-LIST STD-COMPUTE-EFFECTIVE-METHOD GENERATE-EMF-LAMBDA COMPUTE-PRIMARY-EMFUN WALK-FORM COMPUTE-METHOD-FUNCTION COMPUTE-METHOD-FAST-FUNCTION MAKE-METHOD-LAMBDA ALLOW-OTHER-KEYS MAKE-INSTANCE-STANDARD-ACCESSOR-METHOD ADD-READER-METHOD ADD-WRITER-METHOD CHECK-DUPLICATE-SLOTS CHECK-DUPLICATE-DEFAULT-INITARGS ENSURE-CLASS-USING-CLASS READER-METHOD-CLASS WRITER-METHOD-CLASS COMPUTE-APPLICABLE-METHODS-USING-CLASSES SLOT-VALUE-USING-CLASS SLOT-EXISTS-P-USING-CLASS SLOT-BOUNDP-USING-CLASS SLOT-MAKUNBOUND-USING-CLASS CALCULATE-ALLOWABLE-INITARGS CHECK-INITARGS MERGE-INITARGS-SETS EXTRACT-LAMBDA-LIST-KEYWORDS AUGMENT-INITARGS-WITH-DEFAULTS STD-SHARED-INITIALIZE COMPUTE-SLOTS COMPUTE-EFFECTIVE-SLOT-DEFINITION COMPUTE-DISCRIMINATING-FUNCTION METHOD-MORE-SPECIFIC-P COMPUTE-EFFECTIVE-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS SPECIALIZER-DIRECT-METHODS ADD-DEPENDENT REMOVE-DEPENDENT UPDATE-DEPENDENT ENSURE-GENERIC-FUNCTION-USING-CLASS %METHOD-GENERIC-FUNCTION %METHOD-FUNCTION)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(IN-PACKAGE :MOP) +(DOLIST (SYSTEM::FS (QUOTE ((("clos") DEFINE-CLASS->%CLASS-FORWARDER PUSH-ON-END DEFINE-PRIMORDIAL-CLASS GETK WITH-ARGS-LAMBDA-LIST WITH-METHOD-GROUPS ATOMIC-DEFGENERIC REDEFINE-CLASS-FORWARDER SLOT-DEFINITION-DISPATCH)))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(IN-PACKAGE :XP) +(DOLIST (SYSTEM::FS (QUOTE ((("pprint-dispatch") MAKE-PPRINT-DISPATCH-TABLE PPRINT-DISPATCH-TABLE-P MAKE-ENTRY ENTRY-P SET-PPRINT-DISPATCH+ PRIORITY-> ADJUST-COUNTS GET-PRINTER FITS SPECIFIER-CATEGORY ALWAYS-TRUE SPECIFIER-FN CONVERT-BODY FUNCTION-CALL-P PPRINT-DISPATCH-PRINT) (("pprint") STRUCTURE-TYPE-P OUTPUT-WIDTH MAKE-XP-STRUCTURE XP-STRUCTURE-P PUSH-BLOCK-STACK POP-BLOCK-STACK PUSH-PREFIX-STACK POP-PREFIX-STACK ENQUEUE INITIALIZE-XP WRITE-CHAR+ WRITE-STRING+ WRITE-CHAR++ FORCE-SOME-OUTPUT WRITE-STRING++ WRITE-STRING+++ PPRINT-TAB+ PPRINT-NEWLINE+ START-BLOCK END-BLOCK PPRINT-INDENT+ ATTEMPT-TO-OUTPUT FLUSH OUTPUT-LINE SETUP-FOR-NEXT-LINE SET-INDENTATION-PREFIX SET-PREFIX SET-SUFFIX REVERSE-STRING-IN-PLACE MAYBE-INITIATE-XP-PRINTING XP-PRINT DO-XP-PRINTING WRITE+ NON-PRETTY-PRINT MAYBE-PRINT-FAST PRINT-FIXNUM PPRINT-POP-CHECK+ CHECK-BLOCK-ABBREVIATION PRETTY-ARRAY PRETTY-VECTOR PRETTY-NON-VECTOR ARRAY-READABLY-PRINTABLE-P FN-CALL ALTERNATIVE-FN-CALL BIND-LIST BLOCK-LIKE DEFUN-LIKE PRINT-FANCY-FN-CALL LET-PRINT COND-PRINT DMM-PRINT DEFSETF-PRINT DO-PRINT FLET-PRINT FUNCTION-PRINT MVB-PRINT MAYBELAB PROG-PRINT TAGBODY-PRINT SETQ-PRINT QUOTE-PRINT UP-PRINT TOKEN-TYPE PRETTY-LOOP OUTPUT-PRETTY-OBJECT)))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(IN-PACKAGE :XP) +(DOLIST (SYSTEM::FS (QUOTE ((("pprint") LP<-BP TP<-BP BP<-LP BP<-TP LP<-TP CHECK-SIZE SECTION-START PREFIX-PTR SUFFIX-PTR NON-BLANK-PREFIX-PTR INITIAL-PREFIX-PTR SECTION-START-LINE QTYPE QKIND QPOS QDEPTH QEND QOFFSET QARG QNEXT MAYBE-TOO-LARGE MISERING? PPRINT-LOGICAL-BLOCK+ PPRINT-POP+)))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(IN-PACKAGE :PRECOMPILER) +(DOLIST (SYSTEM::FS (QUOTE ())) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(IN-PACKAGE :PROFILER) +(DOLIST (SYSTEM::FS (QUOTE ((("profiler") MAKE-PROFILE-INFO PROFILE-INFO-P LIST-CALLED-OBJECTS OBJECT-NAME OBJECT-COMPILED-FUNCTION-P SHOW-CALL-COUNT SHOW-HOT-COUNT SHOW-CALL-COUNTS SHOW-HOT-COUNTS START-PROFILER)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(IN-PACKAGE :PROFILER) +(DOLIST (SYSTEM::FS (QUOTE ((("profiler") WITH-PROFILING)))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(IN-PACKAGE :JAVA) +(DOLIST (SYSTEM::FS (QUOTE ((("java-collections") JLIST-ADD JLIST-SET JLIST-GET MAKE-JSEQUENCE-LIKE MAKE-JLIST-ITERATOR JSET-ADD) (("java") ADD-URL-TO-CLASSPATH ADD-URLS-TO-CLASSPATH ADD-TO-CLASSPATH JREGISTER-HANDLER JINTERFACE-IMPLEMENTATION JMAKE-INVOCATION-HANDLER JMAKE-PROXY CANONICALIZE-JPROXY-INTERFACES JEQUAL JOBJECT-CLASS JCLASS-SUPERCLASS JCLASS-INTERFACES JCLASS-INTERFACE-P JCLASS-SUPERCLASS-P JCLASS-ARRAY-P JARRAY-COMPONENT-TYPE JARRAY-LENGTH JNEW-ARRAY-FROM-ARRAY JNEW-ARRAY-FROM-LIST JARRAY-FROM-LIST LIST-FROM-JARRAY VECTOR-FROM-JARRAY LIST-FROM-JENUMERATION JCLASS-CONSTRUCTORS JCONSTRUCTOR-PARAMS JCLASS-FIELDS JCLASS-FIELD JFIELD-TYPE JFIELD-NAME JCLASS-METHODS JMETHOD-PARAMS JMETHOD-RETURN-TYPE JMETHOD-DECLARING-CLASS JMETHOD-NAME JINSTANCE-OF-P JMEMBER-STATIC-P JMEMBER-PUBLIC-P JMEMBER-PROTECTED-P JPROPERTY-VALUE JCLASS-ADDITIONAL-SUPERCLASSES ENSURE-JAVA-CLASS JINPUT-STREAM) (("runtime-class") JNEW-RUNTIME-CLASS %JNEW-RUNTIME-CLASS MAKE-ACCESSOR-NAME CANONICALIZE-JAVA-TYPE EMIT-UNBOX-AND-RETURN RUNTIME-CLASS-ADD-METHODS RUNTIME-CLASS-ADD-FIELDS)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(IN-PACKAGE :JAVA) +(DOLIST (SYSTEM::FS (QUOTE ((("java") CHAIN JMETHOD-LET) (("runtime-class") DEFINE-JAVA-CLASS)))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(IN-PACKAGE :JVM) +(DOLIST (SYSTEM::FS (QUOTE ( (("dump-class") READ-U1 READ-U2 READ-U4 LOOKUP-UTF8 READ-CONSTANT-POOL-ENTRY DUMP-CODE DUMP-CODE-ATTRIBUTE DUMP-EXCEPTIONS READ-ATTRIBUTE READ-INFO DUMP-CLASS) (("jvm-class-file") MAP-PRIMITIVE-TYPE %MAKE-JVM-CLASS-NAME JVM-CLASS-NAME-P MAKE-JVM-CLASS-NAME CLASS-ARRAY INTERNAL-FIELD-TYPE INTERNAL-FIELD-REF DESCRIPTOR DESCRIPTOR-STACK-EFFECT MAKE-POOL POOL-P MAKE-CONSTANT CONSTANT-P MAKE-CONSTANT-CLASS CONSTANT-CLASS-P %MAKE-CONSTANT-MEMBER-REF CONSTANT-MEMBER-REF-P MAKE-CONSTANT-FIELD-REF MAKE-CONSTANT-METHOD-REF MAKE-CONSTANT-INTERFACE-METHOD-REF MAKE-CONSTANT-STRING CONSTANT-STRING-P %MAKE-CONSTANT-FLOAT/INT CONSTANT-FLOAT/INT-P MAKE-CONSTANT-FLOAT MAKE-CONSTANT-INT %MAKE-CONSTANT-DOUBLE/LONG CONSTANT-DOUBLE/LONG-P MAKE-CONSTANT-DOUBLE MAKE-CONSTANT-LONG MAKE-CONSTANT-NAME/TYPE CONSTANT-NAME/TYPE-P MAKE-CONSTANT-UTF8 CONSTANT-UTF8-P POOL-ADD-CLASS POOL-ADD-FIELD-REF POOL-ADD-METHOD-REF POOL-ADD-INTERFACE-METHOD-REF POOL-ADD-STRING POOL-ADD-INT POOL-ADD-FLOAT POOL-ADD-LONG POOL-ADD-DOUBLE POOL-ADD-NAME/TYPE POOL-ADD-UTF8 MAKE-CLASS-FILE CLASS-FILE-P MAKE-CLASS-INTERFACE-FILE CLASS-ADD-FIELD CLASS-FIELD CLASS-ADD-METHOD CLASS-METHODS-BY-NAME CLASS-METHOD CLASS-ADD-ATTRIBUTE CLASS-ADD-SUPERINTERFACE CLASS-ATTRIBUTE FINALIZE-INTERFACES FINALIZE-CLASS-FILE WRITE-U1 WRITE-U2 WRITE-U4 WRITE-S4 WRITE-ASCII WRITE-UTF8 WRITE-CLASS-FILE WRITE-CONSTANTS PRINT-CONSTANT MAP-FLAGS %MAKE-FIELD FIELD-P MAKE-FIELD FIELD-ADD-ATTRIBUTE FIELD-ATTRIBUTE FINALIZE-FIELD WRITE-FIELD %MAKE-JVM-METHOD JVM-METHOD-P MAP-METHOD-NAME MAKE-JVM-METHOD METHOD-ADD-ATTRIBUTE METHOD-ADD-CODE METHOD-ENSURE-CODE METHOD-ATTRIBUTE FINALIZE-METHOD WRITE-METHOD MAKE-ATTRIBUTE ATTRIBUTE-P FINALIZE-ATTRIBUTES WRITE-ATTRIBUTES %MAKE-CODE-ATTRIBUTE CODE-ATTRIBUTE-P CODE-LABEL-OFFSET FINALIZE-CODE-ATTRIBUTE WRITE-CODE-ATTRIBUTE MAKE-CODE-ATTRIBUTE CODE-ADD-ATTRIBUTE CODE-ATTRIBUTE CODE-ADD-EXCEPTION-HANDLER MAKE-EXCEPTION EXCEPTION-P MAKE-CONSTANT-VALUE-ATTRIBUTE CONSTANT-VALUE-ATTRIBUTE-P MAKE-CHECKED-EXCEPTIONS-ATTRIBUTE CHECKED-EXCEPTIONS-ATTRIBUTE-P FINALIZE-CHECKED-EXCEPTIONS WRITE-CHECKED-EXCEPTIONS MAKE-DEPRECATED-ATTRIBUTE DEPRECATED-ATTRIBUTE-P SAVE-CODE-SPECIALS RESTORE-CODE-SPECIALS MAKE-SOURCE-FILE-ATTRIBUTE SOURCE-FILE-ATTRIBUTE-P FINALIZE-SOURCE-FILE WRITE-SOURCE-FILE MAKE-SYNTHETIC-ATTRIBUTE SYNTHETIC-ATTRIBUTE-P MAKE-LINE-NUMBERS-ATTRIBUTE LINE-NUMBERS-ATTRIBUTE-P MAKE-LINE-NUMBER LINE-NUMBER-P FINALIZE-LINE-NUMBERS WRITE-LINE-NUMBERS LINE-NUMBERS-ADD-LINE MAKE-LOCAL-VARIABLES-ATTRIBUTE LOCAL-VARIABLES-ATTRIBUTE-P MAKE-LOCAL-VARIABLE LOCAL-VARIABLE-P FINALIZE-LOCAL-VARIABLES WRITE-LOCAL-VARIABLES MAKE-ANNOTATIONS-ATTRIBUTE ANNOTATIONS-ATTRIBUTE-P MAKE-ANNOTATION ANNOTATION-P MAKE-ANNOTATION-ELEMENT ANNOTATION-ELEMENT-P MAKE-PRIMITIVE-OR-STRING-ANNOTATION-ELEMENT PRIMITIVE-OR-STRING-ANNOTATION-ELEMENT-P MAKE-ENUM-VALUE-ANNOTATION-ELEMENT ENUM-VALUE-ANNOTATION-ELEMENT-P MAKE-ANNOTATION-VALUE-ANNOTATION-ELEMENT ANNOTATION-VALUE-ANNOTATION-ELEMENT-P MAKE-ARRAY-ANNOTATION-ELEMENT ARRAY-ANNOTATION-ELEMENT-P MAKE-RUNTIME-VISIBLE-ANNOTATIONS-ATTRIBUTE RUNTIME-VISIBLE-ANNOTATIONS-ATTRIBUTE-P FINALIZE-ANNOTATIONS FINALIZE-ANNOTATION FINALIZE-ANNOTATION-ELEMENT WRITE-ANNOTATIONS WRITE-ANNOTATION WRITE-ANNOTATION-ELEMENT) (("runtime-class") EMIT-INVOKESPECIAL PARSE-ANNOTATION PARSE-ANNOTATION-ELEMENT)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(IN-PACKAGE :JVM) +(DOLIST (SYSTEM::FS (QUOTE ( (("dump-class") OUT) (("jvm") DEFINE-OPCODE EMIT DEFINE-RESOLVER) ))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(IN-PACKAGE :EXTENSIONS) +(DOLIST (SYSTEM::FS (QUOTE ((("collect") COLLECT-NORMAL-EXPANDER COLLECT-LIST-EXPANDER) (("compile-file") COMPILE-FILE-IF-NEEDED) (("compile-system") GROVEL-JAVA-DEFINITIONS COMPILE-SYSTEM) (("debug") SHOW-RESTARTS) (("describe-compiler-policy") DESCRIBE-COMPILER-POLICY) (("featurep") FEATUREP) (("gui") INIT-GUI MAKE-DIALOG-PROMPT-STREAM %MAKE-DIALOG-PROMPT-STREAM) (("pathnames") URL-PATHNAME-SCHEME SET-URL-PATHNAME-SCHEME URL-PATHNAME-AUTHORITY SET-URL-PATHNAME-AUTHORITY URL-PATHNAME-QUERY SET-URL-PATHNAME-QUERY URL-PATHNAME-FRAGMENT SET-URL-PATHNAME-FRAGMENT) (("pprint") CHARPOS) (("run-program") RUN-PROGRAM PROCESS-P PROCESS-ALIVE-P PROCESS-WAIT PROCESS-EXIT-CODE PROCESS-KILL) (("run-shell-command") RUN-SHELL-COMMAND) (("search") SIMPLE-SEARCH) (("socket") GET-SOCKET-STREAM MAKE-SOCKET MAKE-SERVER-SOCKET SOCKET-ACCEPT SOCKET-CLOSE SERVER-SOCKET-CLOSE SOCKET-LOCAL-ADDRESS SOCKET-PEER-ADDRESS SOCKET-LOCAL-PORT SOCKET-PEER-PORT)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(IN-PACKAGE :EXTENSIONS) +(DOLIST (SYSTEM::FS (QUOTE ((("aver") AVER) (("collect") COLLECT) ))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(IN-PACKAGE :THREADS) +(DOLIST (SYSTEM::FS (QUOTE ((("threads") THREAD-FUNCTION-WRAPPER MAKE-MAILBOX MAILBOX-P MAILBOX-SEND MAILBOX-EMPTY-P MAILBOX-READ MAILBOX-PEEK MAKE-MUTEX MUTEX-P GET-MUTEX RELEASE-MUTEX MAKE-THREAD-LOCK)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(IN-PACKAGE :THREADS) +(DOLIST (SYSTEM::FS (QUOTE ((("threads") WITH-MUTEX WITH-THREAD-LOCK)))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(IN-PACKAGE :SYSTEM) +(DOLIST (FS (QUOTE ((("abcl-contrib") FIND-SYSTEM-JAR FIND-CONTRIB) (("assert") ASSERT-ERROR ASSERT-PROMPT) (("aver") %FAILED-AVER) (("bit-array-ops") BIT-ARRAY-SAME-DIMENSIONS-P REQUIRE-SAME-DIMENSIONS PICK-RESULT-ARRAY) (("case") LIST-OF-LENGTH-AT-LEAST-P CASE-BODY-ERROR CASE-BODY-AUX CASE-BODY) (("check-type") CHECK-TYPE-ERROR) (("clos") %DEFGENERIC CANONICALIZE-DIRECT-SUPERCLASSES ENSURE-CLASS) (("coerce") COERCE-LIST-TO-VECTOR COPY-STRING COERCE-ERROR COERCE-OBJECT-TO-AND-TYPE) (("compile-file-pathname") CFP-OUTPUT-FILE-DEFAULT) (("compile-file") BASE-CLASSNAME FASL-LOADER-CLASSNAME COMPUTE-CLASSFILE-NAME SANITIZE-CLASS-NAME NEXT-CLASSFILE-NAME DUMMY VERIFY-LOAD NOTE-TOPLEVEL-FORM OUTPUT-FORM FINALIZE-FASL-OUTPUT SIMPLE-TOPLEVEL-FORM-P CONVERT-TOPLEVEL-FORM PROCESS-PROGN PRECOMPILE-TOPLEVEL-FORM PROCESS-TOPLEVEL-MACROLET PROCESS-TOPLEVEL-DEFCONSTANT PROCESS-TOPLEVEL-QUOTE PROCESS-TOPLEVEL-IMPORT PROCESS-TOPLEVEL-MOP.ENSURE-METHOD PROCESS-TOPLEVEL-DEFVAR/DEFPARAMETER PROCESS-TOPLEVEL-DEFPACKAGE/IN-PACKAGE PROCESS-TOPLEVEL-DECLARE PROCESS-TOPLEVEL-PROGN PROCESS-TOPLEVEL-DEFTYPE PROCESS-TOPLEVEL-EVAL-WHEN PROCESS-TOPLEVEL-DEFMETHOD/DEFGENERIC PROCESS-TOPLEVEL-LOCALLY PROCESS-TOPLEVEL-DEFMACRO PROCESS-TOPLEVEL-DEFUN INSTALL-TOPLEVEL-HANDLER PROCESS-TOPLEVEL-FORM POPULATE-ZIP-FASL WRITE-FASL-PROLOGUE) (("compile-system") CHECK-LISP-HOME GROVEL-JAVA-DEFINITIONS-IN-FILE PACKAGES-FROM-COMBOS REMOVE-MULTI-COMBO-SYMBOLS SET-EQUAL COMBOS-TO-SYMBOL-FILESETS COMBOS-TO-FILESET-SYMBOLS WRITE-AUTOLOADER WRITE-PACKAGE-FILESETS LOAD-COMBOS GENERATE-AUTOLOADS %COMPILE-SYSTEM CREATE-SYSTEM-LOGICAL-TRANSLATIONS) (("compiler-error") COMPILER-STYLE-WARN COMPILER-WARN COMPILER-ERROR INTERNAL-COMPILER-ERROR COMPILER-UNSUPPORTED) (("compiler-macro") COMPILER-MACROEXPAND-1 COMPILER-MACROEXPAND) (("compiler-types") MAKE-CONSTANT-TYPE CONSTANT-TYPE-P %MAKE-INTEGER-TYPE INTEGER-TYPE-P MAKE-INTEGER-TYPE FIXNUM-TYPE-P FIXNUM-CONSTANT-VALUE INTEGER-CONSTANT-VALUE JAVA-LONG-TYPE-P MAKE-UNION-TYPE MAKE-COMPILER-TYPE INTEGER-TYPE-SUBTYPEP COMPILER-SUBTYPEP FUNCTION-RESULT-TYPE SET-FUNCTION-RESULT-TYPE %DEFKNOWN) (("concatenate") CONCATENATE-TO-STRING) (("debug") INTERNAL-DEBUG DEBUG-LOOP INVOKE-DEBUGGER-REPORT-CONDITION RUN-HOOK BACKTRACE-AS-LIST) (("define-symbol-macro") %DEFINE-SYMBOL-MACRO) (("defpackage") DESIGNATED-PACKAGE-NAME STRINGIFY-NAMES CHECK-DISJOINT) (("defsetf") %DEFSETF) (("defstruct") MAKE-DEFSTRUCT-DESCRIPTION MAKE-DEFSTRUCT-SLOT-DESCRIPTION KEYWORDIFY DEFINE-KEYWORD-CONSTRUCTOR FIND-DSD GET-SLOT DEFINE-BOA-CONSTRUCTOR DEFAULT-CONSTRUCTOR-NAME DEFINE-CONSTRUCTORS NAME-INDEX DEFINE-PREDICATE MAKE-LIST-READER MAKE-VECTOR-READER MAKE-STRUCTURE-READER DEFINE-READER MAKE-LIST-WRITER MAKE-VECTOR-WRITER MAKE-STRUCTURE-WRITER DEFINE-WRITER DEFINE-ACCESS-FUNCTIONS DEFINE-COPIER DEFINE-PRINT-FUNCTION PARSE-1-OPTION PARSE-NAME-AND-OPTIONS COMPILER-DEFSTRUCT DEFSTRUCT-DEFAULT-CONSTRUCTOR) (("deftype") EXPAND-DEFTYPE) (("delete-duplicates") LIST-DELETE-DUPLICATES* VECTOR-DELETE-DUPLICATES*) (("describe") DESCRIBE-ARGLIST %DESCRIBE-OBJECT) (("destructuring-bind") PARSE-BODY ARG-COUNT-ERROR PARSE-DEFMACRO DEFMACRO-ERROR VERIFY-KEYWORDS LOOKUP-KEYWORD KEYWORD-SUPPLIED-P PARSE-DEFMACRO-LAMBDA-LIST PUSH-SUB-LIST-BINDING PUSH-LET-BINDING PUSH-OPTIONAL-BINDING MAKE-EXPANDER-FOR-MACROLET) (("directory") PATHNAME-AS-FILE WILD-INFERIORS-P LIST-DIRECTORIES-WITH-WILDCARDS) (("do") DO-DO-BODY) (("dump-form") GET-INSTANCE-FORM DF-REGISTER-CIRCULARITY DF-CHECK-CONS DF-CHECK-VECTOR DF-CHECK-INSTANCE DF-CHECK-OBJECT DF-HANDLE-CIRCULARITY DUMP-CONS DUMP-VECTOR DUMP-INSTANCE DUMP-UNINTERNED-SYMBOL-INDEX DUMP-OBJECT DUMP-FORM) (("ed") DEFAULT-ED-FUNCTION) (("enough-namestring") EQUAL-COMPONENTS-P) (("fill") LIST-FILL VECTOR-FILL) (("find") LIST-POSITION* VECTOR-POSITION* LIST-FIND* VECTOR-FIND*) (("format") SYMBOLICATE PROPER-LIST-OF-LENGTH-P FLONUM-TO-STRING ROUND-UP SCALE-EXPONENT FLOAT-DENORMALIZED-P) (("inline") INLINE-EXPANSION SET-INLINE-EXPANSION) (("inspect") LEADER SAFE-LENGTH DISPLAY-OBJECT DISPLAY-CURRENT ISTEP) (("late-setf") MAKE-GENSYM-LIST) (("lcm") TWO-ARG-LCM) (("ldb") %LDB) (("load") LOAD-RETURNING-LAST-RESULT) (("make-sequence") SIZE-MISMATCH-ERROR) (("map1") MAP1) (("nsubstitute") NLIST-SUBSTITUTE* NVECTOR-SUBSTITUTE* NLIST-SUBSTITUTE-IF* NVECTOR-SUBSTITUTE-IF* NLIST-SUBSTITUTE-IF-NOT* NVECTOR-SUBSTITUTE-IF-NOT*) (("open") UPGRADED-ELEMENT-TYPE-BITS UPGRADED-ELEMENT-TYPE) (("parse-integer") PARSE-INTEGER-ERROR) (("parse-lambda-list") PARSE-LAMBDA-LIST-LIKE-THING PARSE-LAMBDA-LIST) (("pathnames") COMPONENT-MATCH-WILD-P COMPONENT-MATCH-P DIRECTORY-MATCH-COMPONENTS DIRECTORY-MATCH-P WILD-P CASIFY TRANSLATE-COMPONENT TRANSLATE-JAR-DEVICE TRANSLATE-DIRECTORY-COMPONENTS-AUX TRANSLATE-DIRECTORY-COMPONENTS TRANSLATE-DIRECTORY LOGICAL-HOST-P CANONICALIZE-LOGICAL-PATHNAME-TRANSLATIONS %SET-LOGICAL-PATHNAME-TRANSLATIONS) (("print-unreadable-object") %PRINT-UNREADABLE-OBJECT) (("print") COMPOUND-OBJECT-P OUTPUT-INTEGER OUTPUT-LIST OUTPUT-TERSE-ARRAY ARRAY-READABLY-PRINTABLE-P OUTPUT-VECTOR OUTPUT-UGLY-OBJECT CHECK-FOR-CIRCULARITY HANDLE-CIRCULARITY PRINT-LABEL PRINT-REFERENCE UNIQUELY-IDENTIFIED-BY-PRINT-P %PRINT-OBJECT %CHECK-OBJECT OUTPUT-OBJECT) (("proclaim") DECLARATION-ERROR CHECK-DECLARATION-TYPE PROCLAIM-TYPE PROCLAIMED-TYPE PROCLAIM-FTYPE-1 PROCLAIM-FTYPE PROCLAIMED-FTYPE FTYPE-RESULT-TYPE) (("query") QUERY-READLINE) (("read-circle") CIRCLE-SUBST SHARP-EQUAL SHARP-SHARP) (("read-conditional") READ-FEATURE READ-CONDITIONAL) (("remove-duplicates") LIST-REMOVE-DUPLICATES VECTOR-REMOVE-DUPLICATES) (("replace") LIST-REPLACE-FROM-LIST* LIST-REPLACE-FROM-VECTOR* VECTOR-REPLACE-FROM-LIST* VECTOR-REPLACE-FROM-VECTOR*) (("run-program") %MAKE-PROCESS MAKE-PROCESS %MAKE-PROCESS-BUILDER %PROCESS-BUILDER-ENVIRONMENT %PROCESS-BUILDER-ENV-PUT %PROCESS-BUILDER-ENV-CLEAR %PROCESS-BUILDER-START %MAKE-PROCESS-INPUT-STREAM %MAKE-PROCESS-OUTPUT-STREAM %MAKE-PROCESS-ERROR-STREAM %PROCESS-ALIVE-P %PROCESS-WAIT %PROCESS-EXIT-CODE %PROCESS-KILL) (("sequences") MAKE-SEQUENCE-OF-TYPE) (("setf") GET-SETF-METHOD-INVERSE EXPAND-OR-GET-SETF-INVERSE %SET-SUBSEQ %DEFINE-SETF-MACRO %SET-CAAR %SET-CADR %SET-CDAR %SET-CDDR %SET-CAAAR %SET-CADAR %SET-CDAAR %SET-CDDAR %SET-CAADR %SET-CADDR %SET-CDADR %SET-CDDDR %SET-CAAAAR %SET-CADAAR %SET-CDAAAR %SET-CDDAAR %SET-CAADAR %SET-CADDAR %SET-CDADAR %SET-CDDDAR %SET-CAAADR %SET-CADADR %SET-CDAADR %SET-CDDADR %SET-CAADDR %SET-CADDDR %SET-CDADDR %SET-CDDDDR %SET-FIFTH %SET-SIXTH %SET-SEVENTH %SET-EIGHTH %SET-NINTH %SET-TENTH) (("socket") %SOCKET-ADDRESS %SOCKET-PORT) (("sort") MERGE-SORT-VECTORS LAST-CONS-OF MERGE-LISTS MERGE-LISTS-NO-KEY SORT-LIST QUICKSORT QUICK-SORT) (("source-transform") SOURCE-TRANSFORM SET-SOURCE-TRANSFORM EXPAND-SOURCE-TRANSFORM-1 EXPAND-SOURCE-TRANSFORM) (("subst") %SUBST %SUBST-IF %SUBST-IF-NOT) (("subtypep") INITIALIZE-KNOWN-TYPES KNOWN-TYPE-P SUB-INTERVAL-P DIMENSION-SUBTYPEP SIMPLE-SUBTYPEP MAKE-CTYPE CTYPE-SUPER CTYPE-TYPE CTYPE CSUBTYPEP-ARRAY CSUBTYPEP-FUNCTION CSUBTYPEP-COMPLEX CSUBTYPEP %SUBTYPEP) (("time") PICK-OBVIOUS-YEAR LEAP-YEARS-BEFORE) (("trace") MAKE-TRACE-INFO TRACE-INFO-P LIST-TRACED-FUNCTIONS EXPAND-TRACE TRACE-1 TRACED-FUNCTION INDENT UNTRACE-ALL UNTRACE-1) (("tree-equal") TREE-EQUAL-TEST-NOT TREE-EQUAL-TEST) (("typep") SIMPLE-ARRAY-P IN-INTERVAL-P MATCH-DIMENSIONS %TYPEP) (("with-hash-table-iterator") HASH-TABLE-ITERATOR-FUNCTION) (("with-package-iterator") PACKAGE-ITERATOR-FUNCTION) (("with-standard-io-syntax") %WITH-STANDARD-IO-SYNTAX)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR FS) (CAR (CAR FS)))) +(IN-PACKAGE :SYSTEM) +(DOLIST (FS (QUOTE ((("assoc") ASSOC-GUTS) (("chars") EQUAL-CHAR-CODE) (("compile-file") REPORT-ERROR DIAG) (("compiler-types") DEFKNOWN) (("copy-seq") VECTOR-COPY-SEQ LIST-COPY-SEQ) (("define-modify-macro") INCF-COMPLEX DECF-COMPLEX) (("defstruct") DD-NAME DD-CONC-NAME DD-DEFAULT-CONSTRUCTOR DD-CONSTRUCTORS DD-COPIER DD-INCLUDE DD-TYPE DD-NAMED DD-INITIAL-OFFSET DD-PREDICATE DD-PRINT-FUNCTION DD-PRINT-OBJECT DD-DIRECT-SLOTS DD-SLOTS DD-INHERITED-ACCESSORS DSD-NAME DSD-INDEX DSD-READER DSD-INITFORM DSD-TYPE DSD-READ-ONLY) (("delete") MUMBLE-DELETE MUMBLE-DELETE-FROM-END NORMAL-MUMBLE-DELETE NORMAL-MUMBLE-DELETE-FROM-END LIST-DELETE LIST-DELETE-FROM-END NORMAL-LIST-DELETE NORMAL-LIST-DELETE-FROM-END IF-MUMBLE-DELETE IF-MUMBLE-DELETE-FROM-END IF-LIST-DELETE IF-LIST-DELETE-FROM-END IF-NOT-MUMBLE-DELETE IF-NOT-MUMBLE-DELETE-FROM-END IF-NOT-LIST-DELETE IF-NOT-LIST-DELETE-FROM-END) (("find") VECTOR-LOCATER-MACRO LOCATER-TEST-NOT VECTOR-LOCATER LOCATER-IF-TEST VECTOR-LOCATER-IF-MACRO VECTOR-LOCATER-IF VECTOR-LOCATER-IF-NOT LIST-LOCATER-MACRO LIST-LOCATER LIST-LOCATER-IF-MACRO LIST-LOCATER-IF LIST-LOCATER-IF-NOT VECTOR-POSITION LIST-POSITION VECTOR-POSITION-IF LIST-POSITION-IF VECTOR-POSITION-IF-NOT LIST-POSITION-IF-NOT VECTOR-FIND LIST-FIND VECTOR-FIND-IF LIST-FIND-IF VECTOR-FIND-IF-NOT LIST-FIND-IF-NOT) (("format") NAMED-LET ONCE-ONLY) (("list") APPLY-KEY) (("print") PUNT-PRINT-IF-TOO-LONG) (("reduce") LIST-REDUCE LIST-REDUCE-FROM-END) (("remove") MUMBLE-REMOVE-MACRO MUMBLE-REMOVE MUMBLE-REMOVE-FROM-END NORMAL-MUMBLE-REMOVE NORMAL-MUMBLE-REMOVE-FROM-END IF-MUMBLE-REMOVE IF-MUMBLE-REMOVE-FROM-END IF-NOT-MUMBLE-REMOVE IF-NOT-MUMBLE-REMOVE-FROM-END LIST-REMOVE-MACRO LIST-REMOVE LIST-REMOVE-FROM-END NORMAL-LIST-REMOVE NORMAL-LIST-REMOVE-FROM-END IF-LIST-REMOVE IF-LIST-REMOVE-FROM-END IF-NOT-LIST-REMOVE IF-NOT-LIST-REMOVE-FROM-END) (("sequences") TYPE-SPECIFIER-ATOM MAKE-SEQUENCE-LIKE) (("sets") WITH-SET-KEYS STEVE-SPLICE) (("sort") MERGE-VECTORS-BODY MERGE-SORT-BODY QUICKSORT-BODY) (("source-transform") DEFINE-SOURCE-TRANSFORM) (("subst") SATISFIES-THE-TEST)))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR FS) (CAR (CAR FS)))) +(IN-PACKAGE :CL) +(DOLIST (SYSTEM::FS (QUOTE ((("adjoin") ADJOIN) (("apropos") APROPOS-LIST APROPOS) (("arrays") MAKE-ARRAY ADJUST-ARRAY ARRAY-ROW-MAJOR-INDEX BIT SBIT) (("assoc") ASSOC ASSOC-IF ASSOC-IF-NOT RASSOC RASSOC-IF RASSOC-IF-NOT ACONS PAIRLIS COPY-ALIST) (("bit-array-ops") BIT-AND BIT-IOR BIT-XOR BIT-EQV BIT-NAND BIT-NOR BIT-ANDC1 BIT-ANDC2 BIT-ORC1 BIT-ORC2 BIT-NOT) (("boole") BOOLE) (("butlast") BUTLAST NBUTLAST) (("byte-io") WRITE-BYTE READ-BYTE) (("chars") CHAR/= CHAR> CHAR>= CHAR-NOT-EQUAL) (("clos") CLASS-NAME NO-APPLICABLE-METHOD FUNCTION-KEYWORDS SLOT-VALUE SLOT-BOUNDP SLOT-MAKUNBOUND SLOT-EXISTS-P METHOD-QUALIFIERS ENSURE-GENERIC-FUNCTION COMPUTE-APPLICABLE-METHODS DOCUMENTATION SLOT-MISSING SLOT-UNBOUND ALLOCATE-INSTANCE INITIALIZE-INSTANCE REINITIALIZE-INSTANCE CHANGE-CLASS UPDATE-INSTANCE-FOR-DIFFERENT-CLASS MAKE-INSTANCES-OBSOLETE UPDATE-INSTANCE-FOR-REDEFINED-CLASS MAKE-CONDITION INVALID-METHOD-ERROR METHOD-COMBINATION-ERROR FIND-METHOD ADD-METHOD REMOVE-METHOD NO-NEXT-METHOD) (("coerce") COERCE) (("compile-file-pathname") COMPILE-FILE-PATHNAME) (("compile-file") COMPILE-FILE) (("compiler-macro") COMPILER-MACRO-FUNCTION) (("concatenate") CONCATENATE) (("copy-seq") COPY-SEQ) (("copy-symbol") COPY-SYMBOL) (("count") COUNT COUNT-IF COUNT-IF-NOT) (("debug") INVOKE-DEBUGGER BREAK) (("delete-duplicates") DELETE-DUPLICATES) (("delete") DELETE DELETE-IF DELETE-IF-NOT) (("deposit-field") DEPOSIT-FIELD) (("describe") DESCRIBE) (("directory") DIRECTORY) (("disassemble") DISASSEMBLE) (("dribble") DRIBBLE) (("ed") ED) (("enough-namestring") ENOUGH-NAMESTRING) (("ensure-directories-exist") ENSURE-DIRECTORIES-EXIST) (("fill") FILL) (("find-all-symbols") FIND-ALL-SYMBOLS) (("find") POSITION POSITION-IF POSITION-IF-NOT FIND FIND-IF FIND-IF-NOT) (("format") FORMAT) (("gentemp") GENTEMP) (("inspect") INSPECT) (("lcm") LCM) (("ldb") BYTE BYTE-SIZE BYTE-POSITION LDB LDB-TEST DPB) (("ldiff") LDIFF) (("list-length") LIST-LENGTH) (("list") FIFTH SIXTH SEVENTH EIGHTH NINTH TENTH MAKE-LIST COMPLEMENT CONSTANTLY MEMBER) (("load") LOAD) (("make-hash-table") MAKE-HASH-TABLE) (("make-load-form-saving-slots") MAKE-LOAD-FORM-SAVING-SLOTS) (("make-sequence") MAKE-SEQUENCE) (("make-string-output-stream") MAKE-STRING-OUTPUT-STREAM) (("make-string") MAKE-STRING) (("map-into") MAP-INTO) (("map") MAP) (("map1") MAPCAN MAPL MAPLIST MAPCON) (("mask-field") MASK-FIELD) (("member-if") MEMBER-IF MEMBER-IF-NOT) (("mismatch") BAD-SEQ-LIMIT THE-END THE-START CALL-TEST TEST-ERROR MISMATCH) (("nsubstitute") NSUBSTITUTE NSUBSTITUTE-IF NSUBSTITUTE-IF-NOT) (("numbers") SIGNUM ROUND FFLOOR FCEILING FROUND RATIONALIZE GCD ISQRT FLOAT-PRECISION DECODE-FLOAT CONJUGATE PHASE) (("open") OPEN) (("package") MAKE-PACKAGE IMPORT DELETE-PACKAGE) (("parse-integer") PARSE-INTEGER) (("pathnames") PATHNAME-HOST PATHNAME-DEVICE PATHNAME-DIRECTORY PATHNAME-NAME PATHNAME-TYPE WILD-PATHNAME-P PATHNAME-MATCH-P TRANSLATE-PATHNAME LOGICAL-PATHNAME-TRANSLATIONS TRANSLATE-LOGICAL-PATHNAME LOAD-LOGICAL-PATHNAME-TRANSLATIONS LOGICAL-PATHNAME PARSE-NAMESTRING) (("pprint-dispatch") COPY-PPRINT-DISPATCH SET-PPRINT-DISPATCH PPRINT-DISPATCH) (("pprint") WRITE PRINT PRIN1 PRINC PPRINT WRITE-TO-STRING PRIN1-TO-STRING PRINC-TO-STRING WRITE-CHAR WRITE-STRING WRITE-LINE TERPRI FRESH-LINE FINISH-OUTPUT FORCE-OUTPUT CLEAR-OUTPUT PPRINT-NEWLINE PPRINT-INDENT PPRINT-TAB PPRINT-LINEAR PPRINT-FILL PPRINT-TABULAR) (("proclaim") PROCLAIM) (("query") Y-OR-N-P YES-OR-NO-P) (("read-from-string") READ-FROM-STRING) (("read-sequence") READ-SEQUENCE) (("reduce") REDUCE) (("remove-duplicates") REMOVE-DUPLICATES) (("remove") REMOVE REMOVE-IF REMOVE-IF-NOT) (("replace") REPLACE) (("revappend") REVAPPEND) (("search") SEARCH) (("setf") GET-SETF-EXPANSION) (("sets") UNION NUNION INTERSECTION NINTERSECTION SET-DIFFERENCE NSET-DIFFERENCE SET-EXCLUSIVE-OR NSET-EXCLUSIVE-OR SUBSETP) (("sort") MERGE SORT STABLE-SORT) (("strings") STRING-UPCASE STRING-DOWNCASE STRING-CAPITALIZE NSTRING-UPCASE NSTRING-DOWNCASE NSTRING-CAPITALIZE STRING= STRING/= STRING-EQUAL STRING-NOT-EQUAL STRING< STRING> STRING<= STRING>= STRING-LESSP STRING-GREATERP STRING-NOT-LESSP STRING-NOT-GREATERP STRING-LEFT-TRIM STRING-RIGHT-TRIM STRING-TRIM) (("sublis") SUBLIS NSUBLIS) (("subst") SUBST SUBST-IF SUBST-IF-NOT NSUBST NSUBST-IF NSUBST-IF-NOT) (("substitute") LIST-SUBSTITUTE* VECTOR-SUBSTITUTE* SUBSTITUTE SUBSTITUTE-IF SUBSTITUTE-IF-NOT) (("subtypep") SUBTYPEP) (("tailp") TAILP) (("time") DECODE-UNIVERSAL-TIME GET-DECODED-TIME ENCODE-UNIVERSAL-TIME) (("tree-equal") TREE-EQUAL) (("typep") TYPEP) (("upgraded-complex-part-type") UPGRADED-COMPLEX-PART-TYPE) (("write-sequence") WRITE-SEQUENCE)))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(IN-PACKAGE :CL) +(DOLIST (SYSTEM::FS (QUOTE ((("and") AND) (("assert") ASSERT) (("case") CASE CCASE ECASE TYPECASE CTYPECASE ETYPECASE) (("check-type") CHECK-TYPE) (("clos") DEFINE-METHOD-COMBINATION DEFGENERIC DEFMETHOD DEFCLASS DEFINE-CONDITION) (("compiler-macro") DEFINE-COMPILER-MACRO) (("cond") COND) (("count") VECTOR-COUNT-IF LIST-COUNT-IF) (("define-modify-macro") DEFINE-MODIFY-MACRO) (("define-symbol-macro") DEFINE-SYMBOL-MACRO) (("defmacro") DEFMACRO) (("defpackage") DEFPACKAGE) (("defstruct") DEFSTRUCT) (("deftype") DEFTYPE) (("destructuring-bind") DESTRUCTURING-BIND) (("do-all-symbols") DO-ALL-SYMBOLS) (("do-external-symbols") DO-EXTERNAL-SYMBOLS) (("do-symbols") DO-SYMBOLS) (("do") DO DO*) (("dolist") DOLIST) (("dotimes") DOTIMES) (("error") IGNORE-ERRORS) (("format") FORMATTER) (("late-setf") DEFINE-SETF-EXPANDER) (("loop") LOOP-FINISH) (("mismatch") WITH-START-END) (("multiple-value-bind") MULTIPLE-VALUE-BIND) (("multiple-value-list") MULTIPLE-VALUE-LIST) (("multiple-value-setq") MULTIPLE-VALUE-SETQ) (("nth-value") NTH-VALUE) (("or") OR) (("pprint") PPRINT-LOGICAL-BLOCK) (("print-unreadable-object") PRINT-UNREADABLE-OBJECT) (("proclaim") DECLAIM) (("prog") PROG PROG*) (("psetf") PSETF) (("remf") REMF) (("rotatef") ROTATEF) (("setf") SETF) (("shiftf") SHIFTF) (("step") STEP) (("sublis") NSUBLIS-MACRO) (("substitute") REAL-COUNT SUBST-DISPATCH) (("trace") TRACE UNTRACE) (("with-accessors") WITH-ACCESSORS) (("with-hash-table-iterator") WITH-HASH-TABLE-ITERATOR) (("with-input-from-string") WITH-INPUT-FROM-STRING) (("with-open-file") WITH-OPEN-FILE) (("with-output-to-string") WITH-OUTPUT-TO-STRING) (("with-package-iterator") WITH-PACKAGE-ITERATOR) (("with-slots") WITH-SLOTS) (("with-standard-io-syntax") WITH-STANDARD-IO-SYNTAX)))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) Modified: trunk/abcl/src/org/armedbear/lisp/boot.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/boot.lisp Wed Aug 1 03:39:07 2012 (r14035) +++ trunk/abcl/src/org/armedbear/lisp/boot.lisp Wed Aug 1 04:53:36 2012 (r14036) @@ -146,6 +146,7 @@ (defun nreverse (sequence) (sys::%nreverse sequence)) +(load-system-file "autoloads-gen") (load-system-file "autoloads") (load-system-file "early-defuns") (load-system-file "backquote") Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Wed Aug 1 03:39:07 2012 (r14035) +++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Wed Aug 1 04:53:36 2012 (r14036) @@ -79,6 +79,140 @@ (dolist (file files) (grovel-java-definitions-in-file file stream)))))) + +;; +;; Functions to generate autoloads.lisp +;; + +(defun packages-from-combos (combos) + (remove-duplicates (mapcar #'symbol-package + (mapcar #'sys:fdefinition-block-name + (mapcar #'second combos))))) + +(defun remove-multi-combo-symbols (combos) + (remove-if (lambda (x) + (< 1 (count x combos :key #'second))) + combos + :key #'second)) + +(defun set-equal (set1 set2 &key test) + (or (eq set1 set2) + (equal set1 set2) + (and (subsetp set2 set1 :test test) + (subsetp set1 set2 :test test)))) + +(defun combos-to-symbol-filesets (combos) + (let (filesets) + (dolist (combo combos) + (pushnew (list (second combo)) filesets :test #'equal :key #'first) + (pushnew (first combo) + (cdr (assoc (second combo) filesets :test #'equal)) + :test #'string=)) + filesets)) + +(defun combos-to-fileset-symbols (combos) + (let (fileset-symbols) + (dolist (symbol-fileset (combos-to-symbol-filesets combos)) + (pushnew (list (cdr symbol-fileset)) fileset-symbols + :test (lambda (x y) (set-equal x y :test #'string=)) + :key #'first) + (pushnew (first symbol-fileset) + (cdr (assoc (cdr symbol-fileset) fileset-symbols + :test (lambda (x y) (set-equal x y :test #'string=)))))) + fileset-symbols)) + +(defun write-autoloader (stream package type fileset-symbols) + (when fileset-symbols + (write `(in-package ,package) :stream stream) + (terpri stream) + (let ((*package* (find-package package))) + (write `(dolist (fs ',fileset-symbols) + (funcall #',type (cdr fs) (car (car fs)))) :stream stream) + (terpri stream)))) + +(defun write-package-filesets (stream package type filesets-symbols) + (let* ((filter-package (find-package package)) + (filtered-filesets + (remove-if (lambda (x) + (null (cdr x))) + (mapcar (lambda (x) + (cons (car x) + (remove-if-not (lambda (x) + ;;; ### TODO: Support SETF functions + (and (symbolp x) + (eq (symbol-package x) + filter-package))) + (cdr x)))) + filesets-symbols)))) + (write-autoloader stream package type filtered-filesets))) + +(defun load-combos (path-spec) + (let (all-functions) + (dolist (functions-file (directory path-spec) + all-functions) + ;; every file has 1 form: the list of functions in it. + (let ((base-name (pathname-name functions-file))) + (unless (member base-name '("asdf" "gray-streams") :test #'string=) + ;; exclude ASDF and GRAY-STREAMS: they have external + ;; symbols we don't have until we load them, but we need + ;; those symbols to read the symbols files + (with-open-file (f functions-file + :direction :input) + (dolist (function-name (read f)) + (push (list base-name function-name) all-functions)))))))) + +(defun generate-autoloads (symbol-files-pathspec) + (flet ((filter-combos (combos) + (remove-if (lambda (x) + ;; exclude the symbols from the files + ;; below: putting autoloaders on some of + ;; the symbols conflicts with the bootstrapping + ;; Primitives which have been defined Java-side + (member x '( ;; function definitions to be excluded + "fdefinition" "early-defuns" + "require" "signal" + "extensible-sequences-base" "restart" + "extensible-sequences" + ;; macro definitions to be excluded + "macros" "backquote" "precompiler") + :test #'string=)) + (remove-multi-combo-symbols combos) + :key #'first)) + (symbols-pathspec (filespec) + (merge-pathnames filespec symbol-files-pathspec))) + (let ((funcs (filter-combos (load-combos (symbols-pathspec "*.funcs")))) + (macs (filter-combos (load-combos (symbols-pathspec "*.macs"))))) + (with-open-file (f (symbols-pathspec "autoloads-gen.lisp") + :direction :output :if-does-not-exist :create + :if-exists :supersede) + ;; Generate the lisp file. This file will be included after compilation, + ;; so any comments are just for debugging purposes. + (terpri f) + (write-line ";; ---- GENERATED CONTENT BELOW" f) + (terpri f) + (write '(identity T) :stream f) + (dolist (package '(:format :sequence :loop :mop :xp :precompiler + :profiler :java :jvm :extensions :threads + :toplevel :system :cl)) + ;; Limit the set of packages: + ;; During incremental compilation, the packages GRAY-STREAMS + ;; and ASDF are not being created. Nor are these packages + ;; vital to the correct operation of the base system. + (write-line ";; FUNCTIONS" f) + (terpri f) + (write-package-filesets f package 'ext:autoload + (combos-to-fileset-symbols funcs)) + (write-line ";; MACROS" f) + (terpri f) + (write-package-filesets f package 'ext:autoload-macro + (combos-to-fileset-symbols macs))))))) + + +;; +;; --- End of autoloads.lisp +;; + + (defun %compile-system (&key output-path) (let ((*default-pathname-defaults* (pathname *lisp-home*)) (*warn-on-redefinition* nil) @@ -138,11 +272,9 @@ "arrays.lisp" "assert.lisp" "assoc.lisp" - "autoloads.lisp" "aver.lisp" "bit-array-ops.lisp" "boole.lisp" - ;;"boot.lisp" "butlast.lisp" "byte-io.lisp" "case.lisp" @@ -190,7 +322,6 @@ "gui.lisp" "inline.lisp" "inspect.lisp" - ;;"j.lisp" "java.lisp" "java-collections.lisp" "known-functions.lisp" @@ -242,7 +373,6 @@ "restart.lisp" "revappend.lisp" "rotatef.lisp" - ;;"run-benchmarks.lisp" "run-program.lisp" "run-shell-command.lisp" "runtime-class.lisp" @@ -272,7 +402,20 @@ "with-package-iterator.lisp" "with-slots.lisp" "with-standard-io-syntax.lisp" - "write-sequence.lisp"))) + "write-sequence.lisp")) + ;; With all files compiled, we need to use the symbols collected + ;; to generate and compile autoloads.lisp + + ;; Generate the autoloads-gen file in the build directory in order + ;; not to clobber the source file - that should keep the system + ;; buildable + + (format t "; Generating autoloads...~%") + (generate-autoloads output-path) + ;; Compile the file in the build directory instead of the one in the + ;; sources directory - the latter being for bootstrapping only. + (do-compile (merge-pathnames #p"autoloads-gen.lisp" output-path)) + (do-compile "autoloads.lisp")) t)) (defun compile-system (&key quit (zip t) (cls-ext *compile-file-class-extension*) (abcl-ext *compile-file-type*) output-path) Modified: trunk/abcl/src/org/armedbear/lisp/setf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/setf.lisp Wed Aug 1 03:39:07 2012 (r14035) +++ trunk/abcl/src/org/armedbear/lisp/setf.lisp Wed Aug 1 04:53:36 2012 (r14036) @@ -58,9 +58,13 @@ t)))) (defun get-setf-expansion (form &optional environment) - (when (and (consp form) - (autoloadp (%car form))) - (resolve (%car form))) +; ### FIXME: resolving here causes functions to be loaded at +; Macro expansion time instead of upon their first call! +; Discussion to be had on the mailing list. +; EH 2012-08-01 +; (when (and (consp form) +; (autoloadp (%car form))) +; (resolve (%car form))) (let (temp) (cond ((symbolp form) (multiple-value-bind (expansion expanded) @@ -86,8 +90,12 @@ (if (atom place) `(setq ,place ,value-form) (progn - (when (symbolp (%car place)) - (resolve (%car place))) +; ### FIXME: resolving here causes functions to be loaded at +; Macro expansion time instead of upon their first call! +; Discussion to be had on the mailing list. +; EH 2012-08-01 +; (when (symbolp (%car place)) +; (resolve (%car place))) (multiple-value-bind (dummies vals store-vars setter getter) (get-setf-expansion place environment) (let ((inverse (get (car place) 'setf-inverse))) From mevenson at common-lisp.net Wed Aug 1 16:16:10 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 01 Aug 2012 09:16:10 -0700 Subject: [armedbear-cvs] r14037 - trunk/abcl Message-ID: Author: mevenson Date: Wed Aug 1 09:16:09 2012 New Revision: 14037 Log: ant: Always clean before 'abcl.release'. Just so there is never any question that a release is *always* built from scratch. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Wed Aug 1 04:53:36 2012 (r14036) +++ trunk/abcl/build.xml Wed Aug 1 09:16:09 2012 (r14037) @@ -1024,7 +1024,7 @@ + depends="abcl.clean,abcl.binary.tar,abcl.source.tar,abcl.binary.zip,abcl.source.zip"> Author: ehuelsmann Date: Wed Aug 1 13:49:12 2012 New Revision: 14038 Log: Make the JVM exit with a non-zero (89) value when we have errors nesting too deep. Helps Mark write bisect programs :-) Modified: trunk/abcl/src/org/armedbear/lisp/signal.lisp Modified: trunk/abcl/src/org/armedbear/lisp/signal.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/signal.lisp Wed Aug 1 09:16:09 2012 (r14037) +++ trunk/abcl/src/org/armedbear/lisp/signal.lisp Wed Aug 1 13:49:12 2012 (r14038) @@ -71,7 +71,7 @@ *current-error-depth* condition) (if (fboundp 'internal-debug) (internal-debug) - (quit))) + (quit :status 89))) ;; it's a prime and a fibonacci! (t (invoke-debugger condition)))))) From mevenson at common-lisp.net Thu Aug 2 10:32:10 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 02 Aug 2012 03:32:10 -0700 Subject: [armedbear-cvs] r14039 - trunk/abcl Message-ID: Author: mevenson Date: Thu Aug 2 03:32:07 2012 New Revision: 14039 Log: README refresh for abcl-1.1.0-dev. Added Rudi Schlatte. Lexigraphically ordered committers: should we designate Erik as SPOC? TODO: format as a template with a simple dictionary interpolation. Modified: trunk/abcl/README Modified: trunk/abcl/README ============================================================================== --- trunk/abcl/README Wed Aug 1 13:49:12 2012 (r14038) +++ trunk/abcl/README Thu Aug 2 03:32:07 2012 (r14039) @@ -1,9 +1,9 @@ GENERAL INFORMATION =================== -Armed Bear Common Lisp is an implementation of ANSI Common Lisp that -runs in a Java virtual machine. It compiles Lisp code directly to -Java byte code. +Armed Bear Common Lisp is a conforming implementation of ANSI Common +Lisp that runs in a Java virtual machine. It compiles Lisp code +directly to Java byte code. LICENSE @@ -47,7 +47,7 @@ which should result in output like the following - Armed Bear Common Lisp 0.25.0 + Armed Bear Common Lisp 1.1.0-dev Java 1.6.0_21 Sun Microsystems Inc. Java HotSpot(TM) Client VM Low-level initialization completed in 0.3 seconds. @@ -64,13 +64,13 @@ * Use the Ant build tool for Java environments. -* Use the NetBeans 6.x IDE to open ABCL as a project. +* Use the NetBeans [67].x IDE to open ABCL as a project. * Bootstrap ABCL using a Common Lisp implementation. Supported implementations for this process: SBCL, CMUCL, OpenMCL, Allegro CL, LispWorks or CLISP. -In all cases you need a Java 5 or later JDK (JDK 1.5 and 1.6 have been +In all cases you need a Java 5 or later JDK (JDK 1.[567] have been tested). Just the JRE isn't enough, as you need the Java compiler ('javac') to compile the Java source of the ABCL implementation. @@ -182,14 +182,14 @@ ### Tests -ABCL 1.0.0 now fails only 18 out of 21708 total tests in the ANSI CL +ABCL 1.1.0-dev now fails only 1[4-6] out of 21708 total tests in the ANSI CL test suite (derived from the tests originally written for GCL). Maxima's test suite runs without failures. ### Deficiencies -The MOP implementation is incomplete. +The MOP implementation is incompletel untested. Patches to address any of the issues mentioned above will be gladly accepted. @@ -201,10 +201,14 @@ Have fun! On behalf of all ABCL development team and contributors, -Erik Huelsmann -Mark Evenson -Alessio Stalla -Ville Voutilaninen -October 2011 + Mark Evenson + Erik Huelsmann + Rudi Schlatte + Alessio Stalla + Ville Voutilaninen + + +August 2012 + From ehuelsmann at common-lisp.net Thu Aug 2 15:35:21 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 02 Aug 2012 08:35:21 -0700 Subject: [armedbear-cvs] r14040 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Aug 2 08:35:18 2012 New Revision: 14040 Log: Rename argument name and type to improve self-documentation of the code and make more clear in which situation it's used. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu Aug 2 03:32:07 2012 (r14039) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu Aug 2 08:35:18 2012 (r14040) @@ -1167,7 +1167,7 @@ `(let ((,value (getf ,plist ,key ,not-exist))) (if (eq ,not-exist ,value) ,init-form ,value)))) -(defun wrap-with-call-method-macro (gf args-var forms) +(defun wrap-with-call-method-macro (gf args-var emf-form) `(macrolet ((call-method (method &optional next-method-list) `(funcall @@ -1193,7 +1193,7 @@ (compute-effective-method ,gf (generic-function-method-combination ,gf) (process-next-method-list next-method-list)))))) - , at forms)) + ,emf-form)) (defmacro with-args-lambda-list (args-lambda-list generic-function-symbol @@ -1285,12 +1285,12 @@ (with-method-groups ,method-group-specs ,methods ,(if (null args-lambda-list) - `(let ((result (progn , at forms))) + `(let ((emf-form (progn , at forms))) `(lambda (,',args-var) ,(wrap-with-call-method-macro ,generic-function-symbol - ',args-var (list result)))) + ',args-var emf-form))) `(lambda (,args-var) - (let* ((result + (let* ((emf-form (with-args-lambda-list ,args-lambda-list ,generic-function-symbol ,args-var , at forms)) @@ -1298,8 +1298,7 @@ `(lambda (,',args-var) ;; ugly: we're reusing it ;; to prevent calling gensym on every EMF invocation ,(wrap-with-call-method-macro ,generic-function-symbol - ',args-var - (list result))))) + ',args-var emf-form)))) (funcall function ,args-var)))))))) (defun declarationp (expr) From ehuelsmann at common-lisp.net Thu Aug 2 15:36:56 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 02 Aug 2012 08:36:56 -0700 Subject: [armedbear-cvs] r14041 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Aug 2 08:36:56 2012 New Revision: 14041 Log: Rename function to follow terminology used in the spec. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu Aug 2 08:35:18 2012 (r14040) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu Aug 2 08:36:56 2012 (r14041) @@ -1130,7 +1130,7 @@ (defun extract-optional-part (lambda-list) (extract-specified-part '&optional lambda-list)) -(defun parse-define-method-combination-arguments-lambda-list (lambda-list) +(defun parse-define-method-combination-args-lambda-list (lambda-list) ;; Define-method-combination Arguments Lambda Lists ;; http://www.lispworks.com/reference/HyperSpec/Body/03_dj.htm (let ((required (extract-required-part lambda-list)) @@ -1204,7 +1204,7 @@ (noptional (gensym)) (rest-args (gensym))) (multiple-value-bind (whole required optional rest keys aux) - (parse-define-method-combination-arguments-lambda-list args-lambda-list) + (parse-define-method-combination-args-lambda-list args-lambda-list) `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol 'sys::lambda-list)) (,nrequired (length (extract-required-part ,gf-lambda-list))) (,noptional (length (extract-optional-part ,gf-lambda-list))) From mevenson at common-lisp.net Fri Aug 3 05:23:20 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 02 Aug 2012 22:23:20 -0700 Subject: [armedbear-cvs] r14042 - trunk/abcl Message-ID: Author: mevenson Date: Thu Aug 2 22:23:16 2012 New Revision: 14042 Log: ant:abcl.test: Specify JVM args for permgen size so ansi-compiled runs. TODO These should probably be parameterized, and settable from properties, for all ABCL invocations. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Thu Aug 2 08:36:56 2012 (r14041) +++ trunk/abcl/build.xml Thu Aug 2 22:23:16 2012 (r14042) @@ -921,6 +921,18 @@ + + + + + + + + + + + + From ehuelsmann at common-lisp.net Fri Aug 3 06:07:59 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 02 Aug 2012 23:07:59 -0700 Subject: [armedbear-cvs] r14043 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Aug 2 23:07:58 2012 New Revision: 14043 Log: When generating a symbol to use it as a value, do so. (Geez, any idea how long it took me to find out my own changes were *not* the cause of the error I was seeing????) Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu Aug 2 22:23:16 2012 (r14042) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu Aug 2 23:07:58 2012 (r14043) @@ -1164,8 +1164,8 @@ "Similar to getf except eval and return INIT-FORM if KEY has no value in PLIST." (let ((not-exist (gensym)) (value (gensym))) - `(let ((,value (getf ,plist ,key ,not-exist))) - (if (eq ,not-exist ,value) ,init-form ,value)))) + `(let ((,value (getf ,plist ,key ',not-exist))) + (if (eq ',not-exist ,value) ,init-form ,value)))) (defun wrap-with-call-method-macro (gf args-var emf-form) `(macrolet From mevenson at common-lisp.net Fri Aug 3 06:29:01 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 02 Aug 2012 23:29:01 -0700 Subject: [armedbear-cvs] r14044 - trunk/abcl Message-ID: Author: mevenson Date: Thu Aug 2 23:29:01 2012 New Revision: 14044 Log: README: Correct Authors to spelling in Manual. Sorry Ville! Rudi --> Rudolf Modified: trunk/abcl/README Modified: trunk/abcl/README ============================================================================== --- trunk/abcl/README Thu Aug 2 23:07:58 2012 (r14043) +++ trunk/abcl/README Thu Aug 2 23:29:01 2012 (r14044) @@ -1,5 +1,8 @@ +Armed Bear Common Lisp README +============================= + GENERAL INFORMATION -=================== +------------------- Armed Bear Common Lisp is a conforming implementation of ANSI Common Lisp that runs in a Java virtual machine. It compiles Lisp code @@ -194,21 +197,23 @@ Patches to address any of the issues mentioned above will be gladly accepted. +# Contact + Please report problems to the development mailing list: Have fun! +# Authors + On behalf of all ABCL development team and contributors, Mark Evenson Erik Huelsmann - Rudi Schlatte + Rudolf Schlatte Alessio Stalla - Ville Voutilaninen - + Ville Voutilainen August 2012 - From ehuelsmann at common-lisp.net Fri Aug 3 11:53:35 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 03 Aug 2012 04:53:35 -0700 Subject: [armedbear-cvs] r14045 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 3 04:53:33 2012 New Revision: 14045 Log: Fix CLOS::EXTRACT-REQUIRED-PART when there is no required part; e.g. (&key some-key) only. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu Aug 2 23:29:01 2012 (r14044) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Aug 3 04:53:33 2012 (r14045) @@ -1113,9 +1113,13 @@ (if (eq (first lambda-list) key) (cddr lambda-list) lambda-list))) - (ldiff (skip '&environment (skip '&whole lambda-list)) - (member-if #'(lambda (it) (member it lambda-list-keywords)) - lambda-list)))) + (let* ((trimmed-lambda-list + (skip '&environment (skip '&whole lambda-list))) + (after-required-lambda-list + (member-if #'(lambda (it) (member it lambda-list-keywords)) + trimmed-lambda-list))) + (when after-required-lambda-list + (ldiff trimmed-lambda-list after-required-lambda-list))))) (defun extract-specified-part (key lambda-list) (case key From ehuelsmann at common-lisp.net Fri Aug 3 18:56:08 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 03 Aug 2012 11:56:08 -0700 Subject: [armedbear-cvs] r14046 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 3 11:56:03 2012 New Revision: 14046 Log: Fix required-part parsing in case of 'required-part-only'. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Aug 3 04:53:33 2012 (r14045) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Aug 3 11:56:03 2012 (r14046) @@ -1118,8 +1118,9 @@ (after-required-lambda-list (member-if #'(lambda (it) (member it lambda-list-keywords)) trimmed-lambda-list))) - (when after-required-lambda-list - (ldiff trimmed-lambda-list after-required-lambda-list))))) + (if after-required-lambda-list + (ldiff trimmed-lambda-list after-required-lambda-list) + trimmed-lambda-list)))) (defun extract-specified-part (key lambda-list) (case key From ehuelsmann at common-lisp.net Fri Aug 3 19:06:32 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 03 Aug 2012 12:06:32 -0700 Subject: [armedbear-cvs] r14047 - trunk/abcl/test/lisp/abcl Message-ID: Author: ehuelsmann Date: Fri Aug 3 12:06:30 2012 New Revision: 14047 Log: Test adjustment: remove quoting based on previously incorrect understanding. Modified: trunk/abcl/test/lisp/abcl/mop-tests.lisp Modified: trunk/abcl/test/lisp/abcl/mop-tests.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/mop-tests.lisp Fri Aug 3 11:56:03 2012 (r14046) +++ trunk/abcl/test/lisp/abcl/mop-tests.lisp Fri Aug 3 12:06:30 2012 (r14047) @@ -571,7 +571,7 @@ ,@(mapcar (lambda (method) `(call-method ,method)) methods) - (list ,x (length ',others)))) + (list ,x (length ,others)))) (defgeneric dmc-test-mc.7 (x &rest others) (:method-combination dmc-test.7)) From ehuelsmann at common-lisp.net Fri Aug 3 20:06:28 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 03 Aug 2012 13:06:28 -0700 Subject: [armedbear-cvs] r14048 - trunk/abcl/test/lisp/abcl Message-ID: Author: ehuelsmann Date: Fri Aug 3 13:06:25 2012 New Revision: 14048 Log: Move CLOS D-M-C tests to a separate file clos-tests.lisp, because D-M-C isn't MOP... Also define many more tests (more to come) to test our D-M-C implementation. Added: trunk/abcl/test/lisp/abcl/clos-tests.lisp Modified: trunk/abcl/test/lisp/abcl/mop-tests.lisp Added: trunk/abcl/test/lisp/abcl/clos-tests.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/test/lisp/abcl/clos-tests.lisp Fri Aug 3 13:06:25 2012 (r14048) @@ -0,0 +1,436 @@ + +;;; clos-tests.lisp +;;; +;;; Copyright (C) 2010 Erik Huelsmann +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + + +;; These tests are in clos tests, because e.g. D-M-C isn't mop, but *is* clos + +(in-package #:abcl.test.lisp) + + + +;; tests for D-M-C, long form, some taken from SBCL + +;; D-M-C should return the name of the new method combination, nothing else. + +(deftest dmc-return.1 + (define-method-combination dmc-test-return-foo) + dmc-test-return-foo) + +(deftest dmc-return.2 + (define-method-combination dmc-test-return-bar :operator and) + dmc-test-return-bar) + +(deftest dmc-return.3 + (define-method-combination dmc-test-return + (&optional (order :most-specific-first)) + ((around (:around)) + (primary (dmc-test-return) :order order :required t)) + (let ((form (if (rest primary) + `(and ,@(mapcar #'(lambda (method) + `(call-method ,method)) + primary)) + `(call-method ,(first primary))))) + (if around + `(call-method ,(first around) + (,@(rest around) + (make-method ,form))) + form))) + dmc-test-return) + +;; A method combination which originally failed; +;; for different reasons in SBCL than in ABCL (hence leaving out +;; the original comment) + +(define-method-combination dmc-test-mc.1 + (&optional (order :most-specific-first)) + ((around (:around)) + (primary (dmc-test-mc) :order order :required t)) + (let ((form (if (rest primary) + `(and ,@(mapcar #'(lambda (method) + `(call-method ,method)) + primary)) + `(call-method ,(first primary))))) + (if around + `(call-method ,(first around) + (,@(rest around) + (make-method ,form))) + form))) + +(defgeneric dmc-test-mc.1 (&key k) (:method-combination dmc-test-mc.1)) + +(defmethod dmc-test-mc.1 dmc-test-mc (&key k) + k) + +(deftest dmc-test-mc.1 + (dmc-test-mc.1 :k 1) + 1) + + +;; Completely DIY -- also taken from SBCL: +(define-method-combination dmc-test-mc.2 () + ((all-methods *)) + (do ((methods all-methods (rest methods)) + (primary nil) + (around nil)) + ((null methods) + (let ((primary (nreverse primary)) + (around (nreverse around))) + (if primary + (let ((form (if (rest primary) + `(call-method ,(first primary) ,(rest primary)) + `(call-method ,(first primary))))) + (if around + `(call-method ,(first around) (,@(rest around) + (make-method ,form))) + form)) + `(make-method (error "No primary methods"))))) + (let* ((method (first methods)) + (qualifier (first (method-qualifiers method)))) + (cond + ((equal :around qualifier) + (push method around)) + ((null qualifier) + (push method primary)))))) + +(defgeneric dmc-test-mc.2a (val) + (:method-combination dmc-test-mc.2)) + +(defmethod dmc-test-mc.2a ((val number)) + (+ val (if (next-method-p) (call-next-method) 0))) + +(deftest dmc-test-mc.2a + (= (dmc-test-mc.2a 13) 13) + T) + +(defgeneric dmc-test-mc.2b (val) + (:method-combination dmc-test-mc.2)) + +(defmethod dmc-test-mc.2b ((val number)) + (+ val (if (next-method-p) (call-next-method) 0))) + +(defmethod dmc-test-mc.2b :around ((val number)) + (+ val (if (next-method-p) (call-next-method) 0))) + +(deftest dmc-test-mc.2b + (= 26 (dmc-test-mc.2b 13)) + T) + + +;;; Taken from SBCL: error when method sorting is ambiguous +;;; with multiple method groups + +(define-method-combination dmc-test-mc.3a () + ((around (:around)) + (primary * :required t)) + (let ((form (if (rest primary) + `(call-method ,(first primary) ,(rest primary)) + `(call-method ,(first primary))))) + (if around + `(call-method ,(first around) (,@(rest around) + (make-method ,form))) + form))) + +(defgeneric dmc-test-mc.3a (val) + (:method-combination dmc-test-mc.3a)) + +(defmethod dmc-test-mc.3a ((val number)) + (+ val (if (next-method-p) (call-next-method) 0))) + +(defmethod dmc-test-mc.3a :around ((val number)) + (+ val (if (next-method-p) (call-next-method) 0))) + +(defmethod dmc-test-mc.3a :somethingelse ((val number)) + (+ val (if (next-method-p) (call-next-method) 0))) + +(deftest dmc-test-mc.3a + (multiple-value-bind + (value error) + (ignore-errors (wam-test-mc.3a 13)) + (declare (ignore value)) + (typep error 'error)) + T) + +;;; Taken from SBCL: error when method sorting is ambiguous +;;; with a single (non *) method group + + +(define-method-combination dmc-test-mc.3b () + ((methods listp :required t)) + (if (rest methods) + `(call-method ,(first methods) ,(rest methods)) + `(call-method ,(first methods)))) + +(defgeneric dmc-test-mc.3b (val) + (:method-combination dmc-test-mc.3b)) + +(defmethod dmc-test-mc.3b :foo ((val number)) + (+ val (if (next-method-p) (call-next-method) 0))) + +(defmethod dmc-test-mc.3b :bar ((val number)) + (+ val (if (next-method-p) (call-next-method) 0))) + +(deftest dmc-test-mc.3b + (multiple-value-bind + (value error) + (ignore-errors (dmc-test-mc.3b 13)) + (declare (ignore value)) + (typep error 'error)) + T) + + +;; Taken from SBCL: test that GF invocation arguments +;; are correctly bound using the (:arguments ...) form + +(defparameter *dmc-test-4* nil) + +(defun object-lock (obj) + (push "object-lock" *dmc-test-4*) + obj) +(defun unlock (obj) + (push "unlock" *dmc-test-4*) + obj) +(defun lock (obj) + (push "lock" *dmc-test-4*) + obj) + + +(define-method-combination dmc-test-mc.4 () + ((methods *)) + (:arguments object) + `(unwind-protect + (progn (lock (object-lock ,object)) + ,@(mapcar #'(lambda (method) + `(call-method ,method)) + methods)) + (unlock (object-lock ,object)))) + +(defgeneric dmc-test.4 (x) + (:method-combination dmc-test-mc.4)) +(defmethod dmc-test.4 ((x symbol)) + (push "primary" *dmc-test-4*)) +(defmethod dmc-test.4 ((x number)) + (error "foo")) + +(deftest dmc-test.4a + (progn + (setq *dmc-test-4* nil) + (values (equal (dmc-test.4 t) '("primary" "lock" "object-lock")) + (equal *dmc-test-4* '("unlock" "object-lock" + "primary" "lock" "object-lock")))) + T T) + +(deftest dmc-test.4b + (progn + (setq *dmc-test-4* nil) + (ignore-errors (dmc-test.4 1)) + (equal *dmc-test-4* '("unlock" "object-lock" "lock" "object-lock"))) + T) + + +;; From SBCL: method combination (long form) with arguments + +(define-method-combination dmc-test.5 () + ((method-list *)) + (:arguments arg1 arg2 &aux (extra :extra)) + `(progn ,@(mapcar (lambda (method) `(call-method ,method)) method-list))) + +(defgeneric dmc-test-mc.5 (p1 p2 s) + (:method-combination dmc-test.5) + (:method ((p1 number) (p2 t) s) + (vector-push-extend (list 'number p1 p2) s)) + (:method ((p1 string) (p2 t) s) + (vector-push-extend (list 'string p1 p2) s)) + (:method ((p1 t) (p2 t) s1) (vector-push-extend (list t p1 p2) s))) + +(deftest dmc-test.5a + (let ((v (make-array 0 :adjustable t :fill-pointer t))) + (values (dmc-test-mc.5 1 2 v) + (equal (aref v 0) '(number 1 2)) + (equal (aref v 1) '(t 1 2)))) + 1 T T) + + + +(define-method-combination dmc-test.6 () + ((normal ()) + (ignored (:ignore :unused))) + `(list 'result + ,@(mapcar #'(lambda (method) `(call-method ,method)) normal))) + +(defgeneric dmc-test-mc.6 (x) + (:method-combination dmc-test.6) + (:method :ignore ((x number)) (/ 0))) + +(deftest dmc-test-mc.6a + (multiple-value-bind + (value error) + (ignore-errors (dmc-test-mc.6 7)) + (values (null value) + (typep error 'error))) + T T) + + +(define-method-combination dmc-test.7 () + ((methods *)) + (:arguments x &rest others) + `(progn + ,@(mapcar (lambda (method) + `(call-method ,method)) + methods) + (list ,x (length ,others)))) + +(defgeneric dmc-test-mc.7 (x &rest others) + (:method-combination dmc-test.7)) + +(defmethod dmc-test-mc.7 (x &rest others) + (declare (ignore others)) + nil) + +(deftest dmc-test-mc.7a + (equal (apply #'dmc-test-mc.7 :foo (list 1 2 3 4 5 6 7 8)) + '(:foo 8)) + T) + + +;; Tests for D-M-C with :arguments option +;; created due to http://trac.common-lisp.net/armedbear/ticket/201 + +(define-method-combination dmc-test-args-with-whole.1 () + ((methods ())) + (:arguments &whole whole) + `(progn (format nil "using ~a" ,whole) + ,@(mapcar (lambda (method) `(call-method ,method)) + methods))) + +(defgeneric dmc-test-args-with-whole.1 (x) + (:method-combination dmc-test-args-with-whole.1) + (:method (x) x)) + +;; This test fails throws an error under #201 +(deftest dmc-test-args-with-whole.1 + (dmc-test-args-with-whole.1 T) + T) + +(define-method-combination dmc-test-args-with-whole.2 () + ((methods ())) + (:arguments &whole whole &rest rest) + `(progn (format nil "using ~a ~a" whole rest) + ,@(mapcar (lambda (method) `(call-method ,method)) + methods))) + +(defgeneric dmc-test-args-with-whole.2 (x) + (:method-combination dmc-test-args-with-whole.2) + (:method (x) x)) + +(deftest dmc-test-args-with-whole.2 + (dmc-test-args-with-whole.2 T) + T) + + +(define-method-combination dmc-test-args-with-whole.3a () + ((methods ())) + (:arguments &whole whole &optional opt) + `(progn (format nil "using ~a ~a" whole opt) + ,@(mapcar (lambda (method) `(call-method ,method)) + methods))) + +(defgeneric dmc-test-args-with-whole.3a (x) + (:method-combination dmc-test-args-with-whole.3a) + (:method (x) x)) + +(deftest dmc-test-args-with-whole.3a + T + T) + +(define-method-combination dmc-test-args-with-whole.3b () + ((methods ())) + (:arguments &whole whole &optional opt &key k) + `(progn (format nil "using ~a ~a ~a" whole opt k) + ,@(mapcar (lambda (method) `(call-method ,method)) + methods))) + +(defgeneric dmc-test-args-with-whole.3b (x) + (:method-combination dmc-test-args-with-whole.3b) + (:method (x) x)) + +(deftest dmc-test-args-with-whole.3b + T + T) + +(define-method-combination dmc-test-args-with-whole.3c () + ((methods ())) + (:arguments &whole whole &optional opt &rest r) + `(progn (format nil "using ~a ~a ~a" whole opt r) + ,@(mapcar (lambda (method) `(call-method ,method)) + methods))) + +(defgeneric dmc-test-args-with-whole.3c (x) + (:method-combination dmc-test-args-with-whole.3c) + (:method (x) x)) + +(deftest dmc-test-args-with-whole.3c + T + T) + + +(define-method-combination dmc-test-args-with-whole.3d () + ((methods ())) + (:arguments &whole whole &optional opt &rest r &key k) + `(progn (format nil "using ~a ~a ~a ~a" whole opt r k) + ,@(mapcar (lambda (method) `(call-method ,method)) + methods))) + +(defgeneric dmc-test-args-with-whole.3d (x) + (:method-combination dmc-test-args-with-whole.3d) + (:method (x) x)) + +(deftest dmc-test-args-with-whole.3d + T + T) + +(define-method-combination dmc-test-args-with-whole.4 () + ((methods ())) + (:arguments &whole whole &key k) + `(progn (format nil "using ~a ~a" whole k) + ,@(mapcar (lambda (method) `(call-method ,method)) + methods))) + +(defgeneric dmc-test-args-with-whole.4 (x) + (:method-combination dmc-test-args-with-whole.4) + (:method (x) x)) + +(deftest dmc-test-args-with-whole.4 + T + T) + +(define-method-combination dmc-test-args-with-whole.5 () + ((methods ())) + (:arguments &whole whole &aux a) + `(progn (format nil "using ~a ~a" whole a) + ,@(mapcar (lambda (method) `(call-method ,method)) + methods))) + +(defgeneric dmc-test-args-with-whole.5 (x) + (:method-combination dmc-test-args-with-whole.5) + (:method (x) x)) + +(deftest dmc-test-args-with-whole.5 + T + T) + Modified: trunk/abcl/test/lisp/abcl/mop-tests.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/mop-tests.lisp Fri Aug 3 12:06:30 2012 (r14047) +++ trunk/abcl/test/lisp/abcl/mop-tests.lisp Fri Aug 3 13:06:25 2012 (r14048) @@ -17,6 +17,8 @@ ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; CLOS related tests go clos-tssts.lisp + (in-package #:abcl.test.lisp) (deftest compute-applicable-methods.foo.1 @@ -301,308 +303,3 @@ t) - -;; tests for D-M-C, long form, taken from SBCL - -;; D-M-C should return the name of the new method combination, nothing else. - -(deftest dmc-return.1 - (define-method-combination dmc-test-return-foo) - dmc-test-return-foo) - -(deftest dmc-return.2 - (define-method-combination dmc-test-return-bar :operator and) - dmc-test-return-bar) - -(deftest dmc-return.3 - (define-method-combination dmc-test-return - (&optional (order :most-specific-first)) - ((around (:around)) - (primary (dmc-test-return) :order order :required t)) - (let ((form (if (rest primary) - `(and ,@(mapcar #'(lambda (method) - `(call-method ,method)) - primary)) - `(call-method ,(first primary))))) - (if around - `(call-method ,(first around) - (,@(rest around) - (make-method ,form))) - form))) - dmc-test-return) - -;; A method combination which originally failed; -;; for different reasons in SBCL than in ABCL (hence leaving out -;; the original comment) - -(define-method-combination dmc-test-mc.1 - (&optional (order :most-specific-first)) - ((around (:around)) - (primary (dmc-test-mc) :order order :required t)) - (let ((form (if (rest primary) - `(and ,@(mapcar #'(lambda (method) - `(call-method ,method)) - primary)) - `(call-method ,(first primary))))) - (if around - `(call-method ,(first around) - (,@(rest around) - (make-method ,form))) - form))) - -(defgeneric dmc-test-mc.1 (&key k) (:method-combination dmc-test-mc.1)) - -(defmethod dmc-test-mc.1 dmc-test-mc (&key k) - k) - -(deftest dmc-test-mc.1 - (dmc-test-mc.1 :k 1) - 1) - - -;; Completely DIY -- also taken from SBCL: -(define-method-combination dmc-test-mc.2 () - ((all-methods *)) - (do ((methods all-methods (rest methods)) - (primary nil) - (around nil)) - ((null methods) - (let ((primary (nreverse primary)) - (around (nreverse around))) - (if primary - (let ((form (if (rest primary) - `(call-method ,(first primary) ,(rest primary)) - `(call-method ,(first primary))))) - (if around - `(call-method ,(first around) (,@(rest around) - (make-method ,form))) - form)) - `(make-method (error "No primary methods"))))) - (let* ((method (first methods)) - (qualifier (first (method-qualifiers method)))) - (cond - ((equal :around qualifier) - (push method around)) - ((null qualifier) - (push method primary)))))) - -(defgeneric dmc-test-mc.2a (val) - (:method-combination dmc-test-mc.2)) - -(defmethod dmc-test-mc.2a ((val number)) - (+ val (if (next-method-p) (call-next-method) 0))) - -(deftest dmc-test-mc.2a - (= (dmc-test-mc.2a 13) 13) - T) - -(defgeneric dmc-test-mc.2b (val) - (:method-combination dmc-test-mc.2)) - -(defmethod dmc-test-mc.2b ((val number)) - (+ val (if (next-method-p) (call-next-method) 0))) - -(defmethod dmc-test-mc.2b :around ((val number)) - (+ val (if (next-method-p) (call-next-method) 0))) - -(deftest dmc-test-mc.2b - (= 26 (dmc-test-mc.2b 13)) - T) - - -;;; Taken from SBCL: error when method sorting is ambiguous -;;; with multiple method groups - -(define-method-combination dmc-test-mc.3a () - ((around (:around)) - (primary * :required t)) - (let ((form (if (rest primary) - `(call-method ,(first primary) ,(rest primary)) - `(call-method ,(first primary))))) - (if around - `(call-method ,(first around) (,@(rest around) - (make-method ,form))) - form))) - -(defgeneric dmc-test-mc.3a (val) - (:method-combination dmc-test-mc.3a)) - -(defmethod dmc-test-mc.3a ((val number)) - (+ val (if (next-method-p) (call-next-method) 0))) - -(defmethod dmc-test-mc.3a :around ((val number)) - (+ val (if (next-method-p) (call-next-method) 0))) - -(defmethod dmc-test-mc.3a :somethingelse ((val number)) - (+ val (if (next-method-p) (call-next-method) 0))) - -(deftest dmc-test-mc.3a - (multiple-value-bind - (value error) - (ignore-errors (wam-test-mc.3a 13)) - (declare (ignore value)) - (typep error 'error)) - T) - -;;; Taken from SBCL: error when method sorting is ambiguous -;;; with a single (non *) method group - - -(define-method-combination dmc-test-mc.3b () - ((methods listp :required t)) - (if (rest methods) - `(call-method ,(first methods) ,(rest methods)) - `(call-method ,(first methods)))) - -(defgeneric dmc-test-mc.3b (val) - (:method-combination dmc-test-mc.3b)) - -(defmethod dmc-test-mc.3b :foo ((val number)) - (+ val (if (next-method-p) (call-next-method) 0))) - -(defmethod dmc-test-mc.3b :bar ((val number)) - (+ val (if (next-method-p) (call-next-method) 0))) - -(deftest dmc-test-mc.3b - (multiple-value-bind - (value error) - (ignore-errors (dmc-test-mc.3b 13)) - (declare (ignore value)) - (typep error 'error)) - T) - - -;; Taken from SBCL: test that GF invocation arguments -;; are correctly bound using the (:arguments ...) form - -(defparameter *dmc-test-4* nil) - -(defun object-lock (obj) - (push "object-lock" *dmc-test-4*) - obj) -(defun unlock (obj) - (push "unlock" *dmc-test-4*) - obj) -(defun lock (obj) - (push "lock" *dmc-test-4*) - obj) - - -(define-method-combination dmc-test-mc.4 () - ((methods *)) - (:arguments object) - `(unwind-protect - (progn (lock (object-lock ,object)) - ,@(mapcar #'(lambda (method) - `(call-method ,method)) - methods)) - (unlock (object-lock ,object)))) - -(defgeneric dmc-test.4 (x) - (:method-combination dmc-test-mc.4)) -(defmethod dmc-test.4 ((x symbol)) - (push "primary" *dmc-test-4*)) -(defmethod dmc-test.4 ((x number)) - (error "foo")) - -(deftest dmc-test.4a - (progn - (setq *dmc-test-4* nil) - (values (equal (dmc-test.4 t) '("primary" "lock" "object-lock")) - (equal *dmc-test-4* '("unlock" "object-lock" - "primary" "lock" "object-lock")))) - T T) - -(deftest dmc-test.4b - (progn - (setq *dmc-test-4* nil) - (ignore-errors (dmc-test.4 1)) - (equal *dmc-test-4* '("unlock" "object-lock" "lock" "object-lock"))) - T) - - -;; From SBCL: method combination (long form) with arguments - -(define-method-combination dmc-test.5 () - ((method-list *)) - (:arguments arg1 arg2 &aux (extra :extra)) - `(progn ,@(mapcar (lambda (method) `(call-method ,method)) method-list))) - -(defgeneric dmc-test-mc.5 (p1 p2 s) - (:method-combination dmc-test.5) - (:method ((p1 number) (p2 t) s) - (vector-push-extend (list 'number p1 p2) s)) - (:method ((p1 string) (p2 t) s) - (vector-push-extend (list 'string p1 p2) s)) - (:method ((p1 t) (p2 t) s) (vector-push-extend (list t p1 p2) s))) - -(deftest dmc-test.5a - (let ((v (make-array 0 :adjustable t :fill-pointer t))) - (values (dmc-test-mc.5 1 2 v) - (equal (aref v 0) '(number 1 2)) - (equal (aref v 1) '(t 1 2)))) - 1 T T) - - - -(define-method-combination dmc-test.6 () - ((normal ()) - (ignored (:ignore :unused))) - `(list 'result - ,@(mapcar #'(lambda (method) `(call-method ,method)) normal))) - -(defgeneric dmc-test-mc.6 (x) - (:method-combination dmc-test.6) - (:method :ignore ((x number)) (/ 0))) - -(deftest dmc-test-mc.6a - (multiple-value-bind - (value error) - (ignore-errors (dmc-test-mc.6 7)) - (values (null value) - (typep error 'error))) - T T) - - -(define-method-combination dmc-test.7 () - ((methods *)) - (:arguments x &rest others) - `(progn - ,@(mapcar (lambda (method) - `(call-method ,method)) - methods) - (list ,x (length ,others)))) - -(defgeneric dmc-test-mc.7 (x &rest others) - (:method-combination dmc-test.7)) - -(defmethod dmc-test-mc.7 (x &rest others) - (declare (ignore others)) - nil) - -(deftest dmc-test-mc.7a - (equal (apply #'dmc-test-mc.7 :foo (list 1 2 3 4 5 6 7 8)) - '(:foo 8)) - T) - - -(defclass foo-class (standard-class)) -(defmethod mop:validate-superclass ((class foo-class) (superclass standard-object)) - t) - -(deftest validate-superclass.1 - (mop:validate-superclass - (make-instance 'foo-class) - (make-instance 'standard-object)) - t) - - -(defgeneric apply-rule (rule)) -(defmethod apply-rule ((rule t) &aux (context (format nil "~A" rule))) - (format nil "Applying rule '~A' in context '~A'" rule context)) - -;;; See ticket # 199 -(deftest defmethod-&aux.1 - (apply-rule "1") - "Applying rule '1' in context '1'") - \ No newline at end of file From ehuelsmann at common-lisp.net Fri Aug 3 20:43:55 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 03 Aug 2012 13:43:55 -0700 Subject: [armedbear-cvs] r14049 - trunk/abcl Message-ID: Author: ehuelsmann Date: Fri Aug 3 13:43:53 2012 New Revision: 14049 Log: Add the clos-tests.lisp file added in the last commit to the ASD file. Modified: trunk/abcl/abcl.asd Modified: trunk/abcl/abcl.asd ============================================================================== --- trunk/abcl/abcl.asd Fri Aug 3 13:06:25 2012 (r14048) +++ trunk/abcl/abcl.asd Fri Aug 3 13:43:53 2012 (r14049) @@ -40,6 +40,7 @@ #+abcl (:file "mop-tests" :depends-on ("mop-tests-setup")) + (:file "clos-tests") (:file "file-system-tests") #+abcl (:file "jar-pathname" :depends-on From ehuelsmann at common-lisp.net Sat Aug 4 09:41:55 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 04 Aug 2012 02:41:55 -0700 Subject: [armedbear-cvs] r14050 - trunk/abcl/test/lisp/abcl Message-ID: Author: ehuelsmann Date: Sat Aug 4 02:41:51 2012 New Revision: 14050 Log: Correct parameter name in clos test. Modified: trunk/abcl/test/lisp/abcl/clos-tests.lisp Modified: trunk/abcl/test/lisp/abcl/clos-tests.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/clos-tests.lisp Fri Aug 3 13:43:53 2012 (r14049) +++ trunk/abcl/test/lisp/abcl/clos-tests.lisp Sat Aug 4 02:41:51 2012 (r14050) @@ -256,7 +256,7 @@ (vector-push-extend (list 'number p1 p2) s)) (:method ((p1 string) (p2 t) s) (vector-push-extend (list 'string p1 p2) s)) - (:method ((p1 t) (p2 t) s1) (vector-push-extend (list t p1 p2) s))) + (:method ((p1 t) (p2 t) s) (vector-push-extend (list t p1 p2) s))) (deftest dmc-test.5a (let ((v (make-array 0 :adjustable t :fill-pointer t))) From ehuelsmann at common-lisp.net Sat Aug 4 11:41:59 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 04 Aug 2012 04:41:59 -0700 Subject: [armedbear-cvs] r14051 - trunk/abcl/test/lisp/abcl Message-ID: Author: ehuelsmann Date: Sat Aug 4 04:41:58 2012 New Revision: 14051 Log: Write some of the DMC-TEST-ARGS-WITH-WHOLE as they were meant to and add a number of DMC-TEST-ARGS-WITH-OPTIONAL to test more D-M-C cases. Note: abcl doesn't pass all of them at this time. Though work to solve that is under way. Modified: trunk/abcl/test/lisp/abcl/clos-tests.lisp Modified: trunk/abcl/test/lisp/abcl/clos-tests.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/clos-tests.lisp Sat Aug 4 02:41:51 2012 (r14050) +++ trunk/abcl/test/lisp/abcl/clos-tests.lisp Sat Aug 4 04:41:58 2012 (r14051) @@ -355,7 +355,7 @@ (:method (x) x)) (deftest dmc-test-args-with-whole.3a - T + (dmc-test-args-with-whole.3a T) T) (define-method-combination dmc-test-args-with-whole.3b () @@ -370,7 +370,7 @@ (:method (x) x)) (deftest dmc-test-args-with-whole.3b - T + (dmc-test-args-with-whole.3b T) T) (define-method-combination dmc-test-args-with-whole.3c () @@ -385,7 +385,7 @@ (:method (x) x)) (deftest dmc-test-args-with-whole.3c - T + (dmc-test-args-with-whole.3c T) T) @@ -401,7 +401,7 @@ (:method (x) x)) (deftest dmc-test-args-with-whole.3d - T + (dmc-test-args-with-whole.3d T) T) (define-method-combination dmc-test-args-with-whole.4 () @@ -416,7 +416,7 @@ (:method (x) x)) (deftest dmc-test-args-with-whole.4 - T + (dmc-test-args-with-whole.4 T) T) (define-method-combination dmc-test-args-with-whole.5 () @@ -431,6 +431,93 @@ (:method (x) x)) (deftest dmc-test-args-with-whole.5 - T + (dmc-test-args-with-whole.5 T) T) +(define-method-combination dmc-test-args-with-optional.1 () + ((methods ())) + (:arguments &optional a) + `(progn ,@(mapcar (lambda (method) `(call-method ,method)) + methods) + ,a)) + +(defgeneric dmc-test-args-with-optional.1 (x &optional b) + (:method-combination dmc-test-args-with-optional.1) + (:method (x &optional b) (progn x b))) + +(deftest dmc-test-args-with-optional.1a + (dmc-test-args-with-optional.1 T) + nil) + +(deftest dmc-test-args-with-optional.1b + (dmc-test-args-with-optional.1 T T) + T) + +(define-method-combination dmc-test-args-with-optional.2 () + ((methods *)) + (:arguments &optional (a :default)) + (print `(progn ,@(mapcar (lambda (method) `(call-method ,method)) + methods) + ,a))) + +(defgeneric dmc-test-args-with-optional.2 (x &optional b) + (:method-combination dmc-test-args-with-optional.2) + (:method (x &optional b) (progn x b))) + +(deftest dmc-test-args-with-optional.2a + :documentation "TODO" + (dmc-test-args-with-optional.2 T) + :default) + +(deftest dmc-test-args-with-optional.2b + :documentation "Describe what the test does here." + (dmc-test-args-with-optional.2 T T) + T) + +(define-method-combination dmc-test-args-with-optional.3 () + ((methods *)) + (:arguments &optional (a :default)) + (print `(progn ,@(mapcar (lambda (method) `(call-method ,method)) + methods) + ,a))) + +(defgeneric dmc-test-args-with-optional.3 (x) + (:method-combination dmc-test-args-with-optional.3) + (:method (x) (progn x))) + +(deftest dmc-test-args-with-optional.3 + :documentation "TODO" + (dmc-test-args-with-optional.3 T) + nil) + + +(define-method-combination dmc-test-args-with-optional.4 () + ((methods ())) + (:arguments &optional (a :default sup-p)) + `(progn ,@(mapcar (lambda (method) `(call-method ,method)) + methods) + (values ,a ,sup-p))) + +(defgeneric dmc-test-args-with-optional.4a (x &optional b) + (:method-combination dmc-test-args-with-optional.4) + (:method (x &optional b) (progn x b))) + +(deftest dmc-test-args-with-optional.4a + (dmc-test-args-with-optional.4a T) + :default + nil) + +(deftest dmc-test-args-with-optional.4b + (dmc-test-args-with-optional.4a T T) + T + T) + +(defgeneric dmc-test-args-with-optional.4c (x) + (:method-combination dmc-test-args-with-optional.4) + (:method (x) (progn x))) + +(deftest dmc-test-args-with-optional.4c + :documentation "TODO" + (dmc-test-args-with-optional.4c T) + nil + nil) \ No newline at end of file From ehuelsmann at common-lisp.net Sat Aug 4 12:56:30 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 04 Aug 2012 05:56:30 -0700 Subject: [armedbear-cvs] r14052 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 4 05:56:29 2012 New Revision: 14052 Log: Integrate WITH-ARGS-LAMBDA-LIST in COMPUTE-METHOD-TYPE-LAMBDA for me to understand what's going on and to open up performance improvement opportunities in the near future. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Aug 4 04:41:58 2012 (r14051) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Aug 4 05:56:29 2012 (r14052) @@ -1200,36 +1200,6 @@ (process-next-method-list next-method-list)))))) ,emf-form)) -(defmacro with-args-lambda-list (args-lambda-list - generic-function-symbol - gf-args-symbol - &body forms) - (let ((gf-lambda-list (gensym)) - (nrequired (gensym)) - (noptional (gensym)) - (rest-args (gensym))) - (multiple-value-bind (whole required optional rest keys aux) - (parse-define-method-combination-args-lambda-list args-lambda-list) - `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol 'sys::lambda-list)) - (,nrequired (length (extract-required-part ,gf-lambda-list))) - (,noptional (length (extract-optional-part ,gf-lambda-list))) - (,rest-args (subseq ,gf-args-symbol (+ ,nrequired ,noptional))) - ,@(when whole `((,whole ,gf-args-symbol))) - ,@(loop for var in required and i upfrom 0 - collect `(,var (when (< ,i ,nrequired) - (nth ,i ,gf-args-symbol)))) - ,@(loop for (var init-form) in optional and i upfrom 0 - collect - `(,var (if (< ,i ,noptional) - (nth (+ ,nrequired ,i) ,gf-args-symbol) - ,init-form))) - ,@(when rest `((,rest ,rest-args))) - ,@(loop for ((key var) init-form) in keys and i upfrom 0 - collect `(,var (getk ,rest-args ',key ,init-form))) - ,@(loop for (var init-form) in aux and i upfrom 0 - collect `(,var ,init-form))) - , at forms)))) - (defun assert-unambiguous-method-sorting (group-name methods) (let ((specializers (make-hash-table :test 'equal))) (dolist (method methods) @@ -1284,27 +1254,72 @@ method-group-specs declarations forms &allow-other-keys) (declare (ignore name)) (let ((methods (gensym)) - (args-var (gensym))) + (args-var (gensym)) + (gf-lambda-list (gensym)) + (emf-form (gensym))) `(lambda (,generic-function-symbol ,methods , at lambda-list) + ;; This is the lambda which computes the effective method , at declarations (with-method-groups ,method-group-specs ,methods ,(if (null args-lambda-list) - `(let ((emf-form (progn , at forms))) + `(let ((,emf-form (progn , at forms))) `(lambda (,',args-var) + ;; This is the lambda which *is* the effective method + ;; hence gets called on every method invocation + ;; be as efficient in this method as we can be ,(wrap-with-call-method-macro ,generic-function-symbol - ',args-var emf-form))) - `(lambda (,args-var) - (let* ((emf-form - (with-args-lambda-list ,args-lambda-list - ,generic-function-symbol ,args-var - , at forms)) - (function - `(lambda (,',args-var) ;; ugly: we're reusing it - ;; to prevent calling gensym on every EMF invocation - ,(wrap-with-call-method-macro ,generic-function-symbol - ',args-var emf-form)))) - (funcall function ,args-var)))))))) + ',args-var ,emf-form))) + (multiple-value-bind + (whole required optional rest keys aux) + (parse-define-method-combination-args-lambda-list args-lambda-list) + `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol + 'sys::lambda-list)) + (nreq (length (extract-required-part ,gf-lambda-list))) + (nopt (length (extract-optional-part ,gf-lambda-list))) + (,emf-form + (let* (,@(when whole + `((,whole ',args-var))) + ,@(when rest + `((,rest `(subseq ,',args-var + (+ ,nreq ,nopt))))) + ,@(loop for var in required + and i upfrom 0 + collect `(,var (when (< ,i nreq) + `(nth ,,i ,',args-var)))) + ,@(loop for (var initform) in optional + and i upfrom 0 + ;; check for excess parameters + ;; only assign initform if the parameter + ;; isn't in excess: the spec says explicitly + ;; to bind those in excess to forms evaluating + ;; to nil. + ;; This leaves initforms to be used with + ;; parameters not supplied in excess, but + ;; not available arguments list + ;; + ;; Also, if specified, bind "supplied-p" + collect `(,var (if (< ,i nopt) + `(nth ,(+ ,i nreq) + ,',args-var) + ',initform))) + ,@(loop for ((key var) initform) in keys + ;; Same as optional parameters: + ;; even though keywords can't be supplied in + ;; excess, we should bind "supplied-p" in case + ;; the key isn't supplied in the arguments list + collect `(,var `(getk (subseq ,',args-var + (+ ,nreq ,nopt)) ,',key + ,',initform))) + ,@(loop for (var initform) in aux + collect `(,var ',initform))) + , at forms))) + `(lambda (,',args-var) + ;; This is the lambda which *is* the effective method + ;; hence gets called on every method invocation + ;; be as efficient in this method as we can be + ,(wrap-with-call-method-macro ,generic-function-symbol + ',args-var ,emf-form))))))))) (defun declarationp (expr) (and (consp expr) (eq (car expr) 'DECLARE))) From ehuelsmann at common-lisp.net Sat Aug 4 13:57:23 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 04 Aug 2012 06:57:23 -0700 Subject: [armedbear-cvs] r14053 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 4 06:57:20 2012 New Revision: 14053 Log: Factor out the emf generating code from METHOD-COMBINATION-TYPE-LAMBDA into its own function. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Aug 4 05:56:29 2012 (r14052) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Aug 4 06:57:20 2012 (r14053) @@ -1249,13 +1249,69 @@ method-group-specs)) , at forms)))) +(defun method-combination-type-lambda-with-args-emf + (&key args-lambda-list generic-function-symbol forms &allow-other-keys) + (multiple-value-bind + (whole required optional rest keys aux) + (parse-define-method-combination-args-lambda-list args-lambda-list) + (let ((gf-lambda-list (gensym)) + (args-var (gensym)) + (emf-form (gensym))) + `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol + 'sys::lambda-list)) + (nreq (length (extract-required-part ,gf-lambda-list))) + (nopt (length (extract-optional-part ,gf-lambda-list))) + (,emf-form + (let* (,@(when whole + `((,whole ',args-var))) + ,@(when rest + `((,rest `(subseq ,',args-var + (+ ,nreq ,nopt))))) + ,@(loop for var in required + and i upfrom 0 + collect `(,var (when (< ,i nreq) + `(nth ,,i ,',args-var)))) + ,@(loop for (var initform) in optional + and i upfrom 0 + ;; check for excess parameters + ;; only assign initform if the parameter + ;; isn't in excess: the spec says explicitly + ;; to bind those in excess to forms evaluating + ;; to nil. + ;; This leaves initforms to be used with + ;; parameters not supplied in excess, but + ;; not available arguments list + ;; + ;; Also, if specified, bind "supplied-p" + collect `(,var (if (< ,i nopt) + `(nth ,(+ ,i nreq) + ,',args-var) + ',initform))) + ,@(loop for ((key var) initform) in keys + ;; Same as optional parameters: + ;; even though keywords can't be supplied in + ;; excess, we should bind "supplied-p" in case + ;; the key isn't supplied in the arguments list + collect `(,var `(getk (subseq ,',args-var + (+ ,nreq ,nopt)) ,',key + ,',initform))) + ,@(loop for (var initform) in aux + collect `(,var ',initform))) + , at forms))) + `(lambda (,',args-var) + ;; This is the lambda which *is* the effective method + ;; hence gets called on every method invocation + ;; be as efficient in this method as we can be + ,(wrap-with-call-method-macro ,generic-function-symbol + ',args-var ,emf-form)))))) + (defun method-combination-type-lambda - (&key name lambda-list args-lambda-list generic-function-symbol + (&rest all-args + &key name lambda-list args-lambda-list generic-function-symbol method-group-specs declarations forms &allow-other-keys) (declare (ignore name)) (let ((methods (gensym)) (args-var (gensym)) - (gf-lambda-list (gensym)) (emf-form (gensym))) `(lambda (,generic-function-symbol ,methods , at lambda-list) ;; This is the lambda which computes the effective method @@ -1270,56 +1326,7 @@ ;; be as efficient in this method as we can be ,(wrap-with-call-method-macro ,generic-function-symbol ',args-var ,emf-form))) - (multiple-value-bind - (whole required optional rest keys aux) - (parse-define-method-combination-args-lambda-list args-lambda-list) - `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol - 'sys::lambda-list)) - (nreq (length (extract-required-part ,gf-lambda-list))) - (nopt (length (extract-optional-part ,gf-lambda-list))) - (,emf-form - (let* (,@(when whole - `((,whole ',args-var))) - ,@(when rest - `((,rest `(subseq ,',args-var - (+ ,nreq ,nopt))))) - ,@(loop for var in required - and i upfrom 0 - collect `(,var (when (< ,i nreq) - `(nth ,,i ,',args-var)))) - ,@(loop for (var initform) in optional - and i upfrom 0 - ;; check for excess parameters - ;; only assign initform if the parameter - ;; isn't in excess: the spec says explicitly - ;; to bind those in excess to forms evaluating - ;; to nil. - ;; This leaves initforms to be used with - ;; parameters not supplied in excess, but - ;; not available arguments list - ;; - ;; Also, if specified, bind "supplied-p" - collect `(,var (if (< ,i nopt) - `(nth ,(+ ,i nreq) - ,',args-var) - ',initform))) - ,@(loop for ((key var) initform) in keys - ;; Same as optional parameters: - ;; even though keywords can't be supplied in - ;; excess, we should bind "supplied-p" in case - ;; the key isn't supplied in the arguments list - collect `(,var `(getk (subseq ,',args-var - (+ ,nreq ,nopt)) ,',key - ,',initform))) - ,@(loop for (var initform) in aux - collect `(,var ',initform))) - , at forms))) - `(lambda (,',args-var) - ;; This is the lambda which *is* the effective method - ;; hence gets called on every method invocation - ;; be as efficient in this method as we can be - ,(wrap-with-call-method-macro ,generic-function-symbol - ',args-var ,emf-form))))))))) + (apply #'method-combination-type-lambda-with-args-emf all-args)))))) (defun declarationp (expr) (and (consp expr) (eq (car expr) 'DECLARE))) From ehuelsmann at common-lisp.net Sat Aug 4 21:18:01 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 04 Aug 2012 14:18:01 -0700 Subject: [armedbear-cvs] r14054 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 4 14:18:00 2012 New Revision: 14054 Log: More efficient arguments option variable references (&optional and &aux) and support for supplied-p parameters (&optional) for long form D-M-C. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Aug 4 06:57:20 2012 (r14053) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Aug 4 14:18:00 2012 (r14054) @@ -1254,13 +1254,20 @@ (multiple-value-bind (whole required optional rest keys aux) (parse-define-method-combination-args-lambda-list args-lambda-list) - (let ((gf-lambda-list (gensym)) - (args-var (gensym)) + (let* ((gf-lambda-list (gensym)) + (args-var (gensym)) + (args-len-var (when (or (some #'second optional) + (some #'second keys)) + (gensym))) + (binding-forms (gensym)) + (needs-args-len-var (gensym)) (emf-form (gensym))) `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol 'sys::lambda-list)) (nreq (length (extract-required-part ,gf-lambda-list))) (nopt (length (extract-optional-part ,gf-lambda-list))) + (,binding-forms) + (,needs-args-len-var) (,emf-form (let* (,@(when whole `((,whole ',args-var))) @@ -1271,22 +1278,37 @@ and i upfrom 0 collect `(,var (when (< ,i nreq) `(nth ,,i ,',args-var)))) - ,@(loop for (var initform) in optional + ,@(loop for (var initform supplied-var) in optional and i upfrom 0 + for supplied-binding = (or supplied-var + (when initform (gensym))) + for var-binding = (gensym) ;; check for excess parameters ;; only assign initform if the parameter ;; isn't in excess: the spec says explicitly - ;; to bind those in excess to forms evaluating + ;; to bind parameters in excess to forms evaluating ;; to nil. ;; This leaves initforms to be used with ;; parameters not supplied in excess, but - ;; not available arguments list + ;; not available in the arguments list ;; ;; Also, if specified, bind "supplied-p" - collect `(,var (if (< ,i nopt) - `(nth ,(+ ,i nreq) - ,',args-var) - ',initform))) + if supplied-binding + collect `(,supplied-binding + (when (< ,i nopt) + (setq ,needs-args-len-var t) + (push `(,',supplied-binding + (< ,(+ ,i nreq) ,',args-len-var)) + ,binding-forms) + ',supplied-binding)) + collect `(,var (when (< ,i nopt) + (push `(,',var-binding + (if ,',supplied-binding + (nth ,(+ ,i nreq) + ,',args-var) + ,',initform)) + ,binding-forms) + ',var-binding))) ,@(loop for ((key var) initform) in keys ;; Same as optional parameters: ;; even though keywords can't be supplied in @@ -1296,14 +1318,24 @@ (+ ,nreq ,nopt)) ,',key ,',initform))) ,@(loop for (var initform) in aux - collect `(,var ',initform))) + for var-binding = (gensym) + collect `(,var (progn + (push '(,var-binding ,initform) + ,binding-forms) + ',var-binding)))) , at forms))) `(lambda (,',args-var) - ;; This is the lambda which *is* the effective method - ;; hence gets called on every method invocation - ;; be as efficient in this method as we can be - ,(wrap-with-call-method-macro ,generic-function-symbol - ',args-var ,emf-form)))))) + ;; set up bindings to ensure the expressions to which the + ;; variables of the arguments option have been bound are + ;; evaluated exactly once. + (let* (,@(when ,needs-args-len-var + `((,',args-len-var (length ,',args-var)))) + ,@(reverse ,binding-forms)) + ;; This is the lambda which *is* the effective method + ;; hence gets called on every method invocation + ;; be as efficient in this method as we can be + ,(wrap-with-call-method-macro ,generic-function-symbol + ',args-var ,emf-form))))))) (defun method-combination-type-lambda (&rest all-args From ehuelsmann at common-lisp.net Sat Aug 4 21:57:47 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 04 Aug 2012 14:57:47 -0700 Subject: [armedbear-cvs] r14055 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 4 14:57:45 2012 New Revision: 14055 Log: Follow up to r14054: fix the case where initform is NIL. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Aug 4 14:18:00 2012 (r14054) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Aug 4 14:57:45 2012 (r14055) @@ -1261,7 +1261,7 @@ (gensym))) (binding-forms (gensym)) (needs-args-len-var (gensym)) - (emf-form (gensym))) + (emf-form (gensym))) `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol 'sys::lambda-list)) (nreq (length (extract-required-part ,gf-lambda-list))) @@ -1280,8 +1280,7 @@ `(nth ,,i ,',args-var)))) ,@(loop for (var initform supplied-var) in optional and i upfrom 0 - for supplied-binding = (or supplied-var - (when initform (gensym))) + for supplied-binding = (or supplied-var (gensym)) for var-binding = (gensym) ;; check for excess parameters ;; only assign initform if the parameter @@ -1293,7 +1292,6 @@ ;; not available in the arguments list ;; ;; Also, if specified, bind "supplied-p" - if supplied-binding collect `(,supplied-binding (when (< ,i nopt) (setq ,needs-args-len-var t) From mevenson at common-lisp.net Sun Aug 5 05:55:09 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Aug 2012 22:55:09 -0700 Subject: [armedbear-cvs] r14056 - trunk/abcl/contrib/asdf-jar Message-ID: Author: mevenson Date: Sat Aug 4 22:55:08 2012 New Revision: 14056 Log: asdf-jar: Complete the CL:REQUIRE protocol by providing :ASDF-JAR. Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp ============================================================================== --- trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Sat Aug 4 14:57:45 2012 (r14055) +++ trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Sat Aug 4 22:55:08 2012 (r14056) @@ -140,22 +140,4 @@ `(:output-translations (,(merge-pathnames "/**/*.*" jar)) :inherit-configuration)))) - - - - - - - - - - - - - - - - - - - +(provide :asdf-jar) From mevenson at common-lisp.net Sun Aug 5 07:01:38 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sun, 05 Aug 2012 00:01:38 -0700 Subject: [armedbear-cvs] r14057 - trunk/abcl/contrib Message-ID: Author: mevenson Date: Sun Aug 5 00:01:37 2012 New Revision: 14057 Log: abcl-contrib: Flesh out the toplevel README. Modified: trunk/abcl/contrib/README.markdown Modified: trunk/abcl/contrib/README.markdown ============================================================================== --- trunk/abcl/contrib/README.markdown Sat Aug 4 22:55:08 2012 (r14056) +++ trunk/abcl/contrib/README.markdown Sun Aug 5 00:01:37 2012 (r14057) @@ -1,8 +1,8 @@ ABCL-CONTRIB ============ -The contributions to Armed Bear constitute Common Lisp only code that is -potentially useful for system construction and distribution. +The contributions to Armed Bear constitute Common Lisp only code that +is potentially useful for system construction and distribution. abcl-asdf @@ -19,11 +19,34 @@ jss - A higher-order, more Lisp oriented interface for constructing Lisp - interfaces to existing binary code libraries available for the JVM - built on the primitives provided by the JAVA package. + A higher-order, more Lisp oriented interface for constructing Lisp + interfaces to existing binary code libraries available for the JVM + built on the primitives provided by the JAVA package. + +jfli + + The "original" higher-order JVM interop descended from Rich + Hickey's work on the JVM before Clojure. This implementation + currently uses a fork of the public [JFLI][] API that uses the + java interop of the ABCL JAVA package instead of the JNI + interface. + +[jfli]: http://sourceforge.net/projects/jfli/ + +mvn +--- +A collection of various useful JVM artifacts downloaded and cached +by the Aether Maven connector. Requires the maven-3.0.4 executable +"mvn" (or "mvn.bat') to be in the current processes's path. + +jna + Cache, from the network if necessary, the jna-3.0.9.jar in + the current JVM process, allowing the bootstrapping of + dynamically linking to shared executables on the host platform. + + Deprecated ---------- @@ -37,4 +60,10 @@ instead. +# Colophon + +Mark +Created: 2011-09-11 +Revised: 2012-08-04 + From ehuelsmann at common-lisp.net Sun Aug 5 20:27:12 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 05 Aug 2012 13:27:12 -0700 Subject: [armedbear-cvs] r14058 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 5 13:27:10 2012 New Revision: 14058 Log: Follow up to r14054, efficient arguments option variable references for &rest and &key. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Aug 5 00:01:37 2012 (r14057) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Aug 5 13:27:10 2012 (r14058) @@ -1254,6 +1254,9 @@ (multiple-value-bind (whole required optional rest keys aux) (parse-define-method-combination-args-lambda-list args-lambda-list) + (unless rest + (when keys + (setf rest (gensym)))) (let* ((gf-lambda-list (gensym)) (args-var (gensym)) (args-len-var (when (or (some #'second optional) @@ -1272,8 +1275,12 @@ (let* (,@(when whole `((,whole ',args-var))) ,@(when rest - `((,rest `(subseq ,',args-var - (+ ,nreq ,nopt))))) + `((,rest (progn + (push `(,',rest + (subseq ,',args-var + ,(+ nreq nopt))) + ,binding-forms) + ',rest)))) ,@(loop for var in required and i upfrom 0 collect `(,var (when (< ,i nreq) @@ -1307,14 +1314,24 @@ ,',initform)) ,binding-forms) ',var-binding))) - ,@(loop for ((key var) initform) in keys + ,@(loop for ((key var) initform supplied-var) in keys + for supplied-binding = (or supplied-var (gensym)) + for var-binding = (gensym) ;; Same as optional parameters: ;; even though keywords can't be supplied in ;; excess, we should bind "supplied-p" in case ;; the key isn't supplied in the arguments list - collect `(,var `(getk (subseq ,',args-var - (+ ,nreq ,nopt)) ,',key - ,',initform))) + collect `(,supplied-binding + (progn + (push `(,',supplied-binding + (member ,',key ,',rest))) + ',supplied-binding)) + collect `(,var (progn + (push `(,',var-binding + (if ,',supplied-binding + (cadr ,',supplied-binding) + ,',initform)) + ,binding-forms)))) ,@(loop for (var initform) in aux for var-binding = (gensym) collect `(,var (progn From ehuelsmann at common-lisp.net Sun Aug 5 20:40:14 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 05 Aug 2012 13:40:14 -0700 Subject: [armedbear-cvs] r14059 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 5 13:40:13 2012 New Revision: 14059 Log: Follow up to r14058: efficient binding of required vars. Also: - Fixes for r14058 - Removal of a macro no longer in use - Code comments as to my opinion on the current state Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Aug 5 13:27:10 2012 (r14058) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Aug 5 13:40:13 2012 (r14059) @@ -1165,13 +1165,6 @@ `(,spec nil))) aux)))) -(defmacro getk (plist key init-form) - "Similar to getf except eval and return INIT-FORM if KEY has no value in PLIST." - (let ((not-exist (gensym)) - (value (gensym))) - `(let ((,value (getf ,plist ,key ',not-exist))) - (if (eq ',not-exist ,value) ,init-form ,value)))) - (defun wrap-with-call-method-macro (gf args-var emf-form) `(macrolet ((call-method (method &optional next-method-list) @@ -1275,16 +1268,21 @@ (let* (,@(when whole `((,whole ',args-var))) ,@(when rest + ;; ### TODO: use a fresh symbol for the rest + ;; binding being generated and pushed into binding-forms `((,rest (progn (push `(,',rest (subseq ,',args-var ,(+ nreq nopt))) ,binding-forms) ',rest)))) - ,@(loop for var in required - and i upfrom 0 + ,@(loop for var in required and i upfrom 0 + for var-binding = (gensym) collect `(,var (when (< ,i nreq) - `(nth ,,i ,',args-var)))) + (push `(,',var-binding + (nth ,,i ,',args-var)) + ,binding-forms) + ',var-binding))) ,@(loop for (var initform supplied-var) in optional and i upfrom 0 for supplied-binding = (or supplied-var (gensym)) @@ -1302,6 +1300,8 @@ collect `(,supplied-binding (when (< ,i nopt) (setq ,needs-args-len-var t) + ;; ### TODO: use a fresh symbol for the supplied binding + ;; binding being generated and pushed into binding-forms (push `(,',supplied-binding (< ,(+ ,i nreq) ,',args-len-var)) ,binding-forms) @@ -1323,15 +1323,19 @@ ;; the key isn't supplied in the arguments list collect `(,supplied-binding (progn + ;; ### TODO: use a fresh symbol for the rest + ;; binding being generated and pushed into binding-forms (push `(,',supplied-binding - (member ,',key ,',rest))) + (member ,',key ,',rest)) + ,binding-forms) ',supplied-binding)) collect `(,var (progn (push `(,',var-binding (if ,',supplied-binding (cadr ,',supplied-binding) ,',initform)) - ,binding-forms)))) + ,binding-forms) + ',var-binding))) ,@(loop for (var initform) in aux for var-binding = (gensym) collect `(,var (progn From ehuelsmann at common-lisp.net Mon Aug 6 05:41:32 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 05 Aug 2012 22:41:32 -0700 Subject: [armedbear-cvs] r14060 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 5 22:41:30 2012 New Revision: 14060 Log: Fix #202: ENSURE-GENERIC-FUNCTION complains about lambda list congruence when no lambda list is provided. Don't change the field when the argument is not provided and when the argument is not provided, don't check for congruence. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Aug 5 13:40:13 2012 (r14059) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Aug 5 22:41:30 2012 (r14060) @@ -1723,32 +1723,35 @@ (defun ensure-generic-function (function-name &rest all-keys &key - lambda-list + (lambda-list nil lambda-list-supplied-p) (generic-function-class +the-standard-generic-function-class+) (method-class +the-standard-method-class+) (method-combination +the-standard-method-combination+ mc-p) argument-precedence-order - documentation + (documentation nil documentation-supplied-p) &allow-other-keys) (setf all-keys (copy-list all-keys)) ; since we modify it (remf all-keys :generic-function-class) (let ((gf (find-generic-function function-name nil))) (if gf (progn - (unless (or (null (generic-function-methods gf)) - (lambda-lists-congruent-p lambda-list (generic-function-lambda-list gf))) - (error 'simple-error - :format-control "The lambda list ~S is incompatible with the existing methods of ~S." - :format-arguments (list lambda-list gf))) - (setf (generic-function-lambda-list gf) lambda-list) - (setf (generic-function-documentation gf) documentation) - (let* ((plist (analyze-lambda-list lambda-list)) - (required-args (getf plist ':required-args))) - (%set-gf-required-args gf required-args) - (%set-gf-optional-args gf (getf plist :optional-args)) - (setf (generic-function-argument-precedence-order gf) - (or argument-precedence-order required-args)) - (finalize-standard-generic-function gf)) + (when lambda-list-supplied-p + (unless (or (null (generic-function-methods gf)) + (lambda-lists-congruent-p lambda-list + (generic-function-lambda-list gf))) + (error 'simple-error + :format-control "The lambda list ~S is incompatible with the existing methods of ~S." + :format-arguments (list lambda-list gf))) + (setf (generic-function-lambda-list gf) lambda-list) + (let* ((plist (analyze-lambda-list lambda-list)) + (required-args (getf plist ':required-args))) + (%set-gf-required-args gf required-args) + (%set-gf-optional-args gf (getf plist :optional-args)))) + (setf (generic-function-argument-precedence-order gf) + (or argument-precedence-order (gf-required-args gf))) + (when documentation-supplied-p + (setf (generic-function-documentation gf) documentation)) + (finalize-standard-generic-function gf) gf) (progn (when (and (null *clos-booting*) @@ -4486,14 +4489,15 @@ name &allow-other-keys)) -(defmethod ensure-generic-function-using-class ((generic-function generic-function) - function-name - &rest all-keys - &key (generic-function-class +the-standard-generic-function-class+) - lambda-list - (method-class +the-standard-method-class+) - (method-combination +the-standard-method-combination+) - &allow-other-keys) +(defmethod ensure-generic-function-using-class + ((generic-function generic-function) + function-name + &rest all-keys + &key (generic-function-class +the-standard-generic-function-class+) + (lambda-list nil lambda-list-supplied-p) + (method-class +the-standard-method-class+) + (method-combination +the-standard-method-combination+) + &allow-other-keys) (setf all-keys (copy-list all-keys)) ; since we modify it (remf all-keys :generic-function-class) (unless (classp generic-function-class) @@ -4502,10 +4506,12 @@ (unless (eq generic-function-class (class-of generic-function)) (error "The class ~S is incompatible with the existing class (~S) of ~S." generic-function-class (class-of generic-function) generic-function)) - (unless (or (null (generic-function-methods generic-function)) - (lambda-lists-congruent-p lambda-list (generic-function-lambda-list generic-function))) - (error "The lambda list ~S is incompatible with the existing methods of ~S." - lambda-list generic-function)) + (when lambda-list-supplied-p + (unless (or (null (generic-function-methods generic-function)) + (lambda-lists-congruent-p lambda-list + (generic-function-lambda-list generic-function))) + (error "The lambda list ~S is incompatible with the existing methods of ~S." + lambda-list generic-function))) (unless (or (null (generic-function-methods generic-function)) (eq method-class (generic-function-method-class generic-function))) (error "The method class ~S is incompatible with the existing methods of ~S." From ehuelsmann at common-lisp.net Mon Aug 6 07:46:00 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Mon, 06 Aug 2012 00:46:00 -0700 Subject: [armedbear-cvs] r14061 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Aug 6 00:45:59 2012 New Revision: 14061 Log: Qualify FIND-PACKAGE when used to serialize a package in a FASL: the current package at FASL load time may not import the CL package. Patch by: Vladimir Sedach. Modified: trunk/abcl/src/org/armedbear/lisp/Package.java trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Package.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Package.java Sun Aug 5 22:41:30 2012 (r14060) +++ trunk/abcl/src/org/armedbear/lisp/Package.java Mon Aug 6 00:45:59 2012 (r14061) @@ -865,7 +865,7 @@ public String printObject() { if (_PRINT_FASL_.symbolValue() != NIL && name != null) { - StringBuilder sb = new StringBuilder("#.(FIND-PACKAGE \""); + StringBuilder sb = new StringBuilder("#.(CL:FIND-PACKAGE \""); sb.append(name); sb.append("\")"); return sb.toString(); Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Aug 5 22:41:30 2012 (r14060) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Mon Aug 6 00:45:59 2012 (r14061) @@ -1191,7 +1191,7 @@ (defun serialize-package (pkg) "Generate code to restore a serialized package." - (emit 'ldc (pool-string (concatenate 'string "#.(FIND-PACKAGE \"" + (emit 'ldc (pool-string (concatenate 'string "#.(CL:FIND-PACKAGE \"" (package-name pkg) "\")"))) (emit-invokestatic +lisp+ "readObjectFromString" (list +java-string+) +lisp-object+)) From rschlatte at common-lisp.net Mon Aug 6 19:02:34 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Mon, 06 Aug 2012 12:02:34 -0700 Subject: [armedbear-cvs] r14062 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Mon Aug 6 12:02:32 2012 New Revision: 14062 Log: Robustify readably-printed NaNs in the spirit of #14061 Modified: trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java trunk/abcl/src/org/armedbear/lisp/SingleFloat.java Modified: trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java Mon Aug 6 00:45:59 2012 (r14061) +++ trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java Mon Aug 6 12:02:32 2012 (r14062) @@ -590,7 +590,7 @@ if (value != value) { if (printReadably) - return "#.(progn \"Comment: create a NaN.\" (/ 0.0d0 0.0d0))"; + return "#.(CL:PROGN \"Comment: create a NaN.\" (CL:/ 0.0d0 0.0d0))"; else return unreadableString("DOUBLE-FLOAT NaN", false); } Modified: trunk/abcl/src/org/armedbear/lisp/SingleFloat.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SingleFloat.java Mon Aug 6 00:45:59 2012 (r14061) +++ trunk/abcl/src/org/armedbear/lisp/SingleFloat.java Mon Aug 6 12:02:32 2012 (r14062) @@ -579,7 +579,7 @@ if (value != value) { if (printReadably) - return "#.(progn \"Comment: create a NaN.\" (/ 0.0s0 0.0s0))"; + return "#.(CL:PROGN \"Comment: create a NaN.\" (CL:/ 0.0s0 0.0s0))"; else return unreadableString("SINGLE-FLOAT NaN", false); } From rschlatte at common-lisp.net Tue Aug 7 10:36:35 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Tue, 07 Aug 2012 03:36:35 -0700 Subject: [armedbear-cvs] r14063 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Tue Aug 7 03:36:33 2012 New Revision: 14063 Log: Add :MOP to *FEATURES* - also simplify *features* initialization a bit Modified: trunk/abcl/src/org/armedbear/lisp/Keyword.java trunk/abcl/src/org/armedbear/lisp/Lisp.java Modified: trunk/abcl/src/org/armedbear/lisp/Keyword.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Keyword.java Mon Aug 6 12:02:32 2012 (r14062) +++ trunk/abcl/src/org/armedbear/lisp/Keyword.java Tue Aug 7 03:36:33 2012 (r14063) @@ -104,6 +104,7 @@ LOAD_TOPLEVEL = internKeyword("LOAD-TOPLEVEL"), LOCAL = internKeyword("LOCAL"), LONG = internKeyword("LONG"), + MOP = internKeyword("MOP"), NAME = internKeyword("NAME"), NETBSD = internKeyword("NETBSD"), NEW_VERSION = internKeyword("NEW"), Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java Mon Aug 6 12:02:32 2012 (r14062) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Tue Aug 7 03:36:33 2012 (r14063) @@ -2323,118 +2323,60 @@ // ### *features* static { - Symbol.FEATURES.initializeSpecial(NIL); - String osName = System.getProperty("os.name"); + final String osName = System.getProperty("os.name"); + final String version = System.getProperty("java.version"); + final String os_arch = System.getProperty("os.arch"); + + // Common features + LispObject featureList = list(Keyword.ARMEDBEAR, Keyword.ABCL, + Keyword.COMMON_LISP, Keyword.ANSI_CL, + Keyword.CDR6, Keyword.MOP); + // OS type if (osName.startsWith("Linux")) - { - Symbol.FEATURES.setSymbolValue(list(Keyword.ARMEDBEAR, - Keyword.ABCL, - Keyword.COMMON_LISP, - Keyword.ANSI_CL, - Keyword.UNIX, - Keyword.LINUX, - Keyword.CDR6)); - } + featureList = Primitives.APPEND.execute(list(Keyword.UNIX, + Keyword.LINUX), + featureList); else if (osName.startsWith("SunOS")) - { - Symbol.FEATURES.setSymbolValue(list(Keyword.ARMEDBEAR, - Keyword.ABCL, - Keyword.COMMON_LISP, - Keyword.ANSI_CL, - Keyword.UNIX, - Keyword.SUNOS, - Keyword.SOLARIS, - Keyword.CDR6)); - } + featureList = Primitives.APPEND.execute(list(Keyword.UNIX, + Keyword.SUNOS, + Keyword.SOLARIS), + featureList); else if (osName.startsWith("Mac OS X") || osName.startsWith("Darwin")) - { - Symbol.FEATURES.setSymbolValue(list(Keyword.ARMEDBEAR, - Keyword.ABCL, - Keyword.COMMON_LISP, - Keyword.ANSI_CL, - Keyword.UNIX, - Keyword.DARWIN, - Keyword.CDR6)); - } + featureList = Primitives.APPEND.execute(list(Keyword.UNIX, + Keyword.DARWIN), + featureList); else if (osName.startsWith("FreeBSD")) - { - Symbol.FEATURES.setSymbolValue(list(Keyword.ARMEDBEAR, - Keyword.ABCL, - Keyword.COMMON_LISP, - Keyword.ANSI_CL, - Keyword.UNIX, - Keyword.FREEBSD, - Keyword.CDR6)); - } + featureList = Primitives.APPEND.execute(list(Keyword.UNIX, + Keyword.FREEBSD), + featureList); else if (osName.startsWith("OpenBSD")) - { - Symbol.FEATURES.setSymbolValue(list(Keyword.ARMEDBEAR, - Keyword.ABCL, - Keyword.COMMON_LISP, - Keyword.ANSI_CL, - Keyword.UNIX, - Keyword.OPENBSD, - Keyword.CDR6)); - } + featureList = Primitives.APPEND.execute(list(Keyword.UNIX, + Keyword.OPENBSD), + featureList); else if (osName.startsWith("NetBSD")) - { - Symbol.FEATURES.setSymbolValue(list(Keyword.ARMEDBEAR, - Keyword.ABCL, - Keyword.COMMON_LISP, - Keyword.ANSI_CL, - Keyword.UNIX, - Keyword.NETBSD, - Keyword.CDR6)); - } + featureList = Primitives.APPEND.execute(list(Keyword.UNIX, + Keyword.NETBSD), + featureList); else if (osName.startsWith("Windows")) - { - Symbol.FEATURES.setSymbolValue(list(Keyword.ARMEDBEAR, - Keyword.ABCL, - Keyword.COMMON_LISP, - Keyword.ANSI_CL, - Keyword.WINDOWS, - Keyword.CDR6)); - } - else - { - Symbol.FEATURES.setSymbolValue(list(Keyword.ARMEDBEAR, - Keyword.ABCL, - Keyword.COMMON_LISP, - Keyword.ANSI_CL, - Keyword.CDR6)); - } - } - static - { - final String version = System.getProperty("java.version"); - if (version.startsWith("1.5")) - { - Symbol.FEATURES.setSymbolValue(new Cons(Keyword.JAVA_1_5, - Symbol.FEATURES.getSymbolValue())); - } - else if (version.startsWith("1.6")) - { - Symbol.FEATURES.setSymbolValue(new Cons(Keyword.JAVA_1_6, - Symbol.FEATURES.getSymbolValue())); - } - else if (version.startsWith("1.7")) - { - Symbol.FEATURES.setSymbolValue(new Cons(Keyword.JAVA_1_7, - Symbol.FEATURES.getSymbolValue())); - } - } - static - { - String os_arch = System.getProperty("os.arch"); + featureList = new Cons(Keyword.WINDOWS, featureList); + // Java version + if (version.startsWith("1.5")) { + featureList = new Cons(Keyword.JAVA_1_5, featureList); + } else if (version.startsWith("1.6")) { + featureList = new Cons(Keyword.JAVA_1_6, featureList); + } else if (version.startsWith("1.7")) { + featureList = new Cons(Keyword.JAVA_1_7, featureList); + } + // Processor architecture if(os_arch != null) { if (os_arch.equals("amd64")) - Symbol.FEATURES.setSymbolValue(new Cons(Keyword.X86_64, - Symbol.FEATURES.getSymbolValue())); + featureList = new Cons(Keyword.X86_64, featureList); else if (os_arch.equals("x86")) - Symbol.FEATURES.setSymbolValue(new Cons(Keyword.X86, - Symbol.FEATURES.getSymbolValue())); + featureList = new Cons(Keyword.X86, featureList); } + Symbol.FEATURES.initializeSpecial(NIL); + Symbol.FEATURES.setSymbolValue(featureList); } static From rschlatte at common-lisp.net Tue Aug 7 16:50:16 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Tue, 07 Aug 2012 09:50:16 -0700 Subject: [armedbear-cvs] r14064 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Tue Aug 7 09:50:15 2012 New Revision: 14064 Log: Cosmetic changes - rename local variables - directly set initial value of *features* Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java Tue Aug 7 03:36:33 2012 (r14063) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Tue Aug 7 09:50:15 2012 (r14064) @@ -2324,8 +2324,8 @@ static { final String osName = System.getProperty("os.name"); - final String version = System.getProperty("java.version"); - final String os_arch = System.getProperty("os.arch"); + final String javaVersion = System.getProperty("java.version"); + final String osArch = System.getProperty("os.arch"); // Common features LispObject featureList = list(Keyword.ARMEDBEAR, Keyword.ABCL, @@ -2361,22 +2361,21 @@ else if (osName.startsWith("Windows")) featureList = new Cons(Keyword.WINDOWS, featureList); // Java version - if (version.startsWith("1.5")) { + if (javaVersion.startsWith("1.5")) { featureList = new Cons(Keyword.JAVA_1_5, featureList); - } else if (version.startsWith("1.6")) { + } else if (javaVersion.startsWith("1.6")) { featureList = new Cons(Keyword.JAVA_1_6, featureList); - } else if (version.startsWith("1.7")) { + } else if (javaVersion.startsWith("1.7")) { featureList = new Cons(Keyword.JAVA_1_7, featureList); } // Processor architecture - if(os_arch != null) { - if (os_arch.equals("amd64")) + if(osArch != null) { + if (osArch.equals("amd64")) featureList = new Cons(Keyword.X86_64, featureList); - else if (os_arch.equals("x86")) + else if (osArch.equals("x86")) featureList = new Cons(Keyword.X86, featureList); } - Symbol.FEATURES.initializeSpecial(NIL); - Symbol.FEATURES.setSymbolValue(featureList); + Symbol.FEATURES.initializeSpecial(featureList); } static From mevenson at common-lisp.net Wed Aug 8 06:41:54 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 07 Aug 2012 23:41:54 -0700 Subject: [armedbear-cvs] r14065 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue Aug 7 23:41:52 2012 New Revision: 14065 Log: abcl-contrib: avoid duplicate entries in ASF:*CENTRAL-REGISTRY*. Modified: trunk/abcl/src/org/armedbear/lisp/abcl-contrib.lisp Modified: trunk/abcl/src/org/armedbear/lisp/abcl-contrib.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/abcl-contrib.lisp Tue Aug 7 09:50:15 2012 (r14064) +++ trunk/abcl/src/org/armedbear/lisp/abcl-contrib.lisp Tue Aug 7 23:41:52 2012 (r14065) @@ -45,14 +45,13 @@ :directory '(:absolute :wild) :name :wild :type "asd"))) - (let ((asdf-directory - (make-pathname :defaults asdf-file :name nil :type nil))) - (format verbose "Adding ~A to ASDF.~%" asdf-directory) - (push asdf-directory asdf:*central-registry*))) + (let ((asdf-directory (make-pathname :defaults asdf-file :name nil :type nil))) + (unless (find asdf-directory asdf:*central-registry* :test #'equal) + (push asdf-directory asdf:*central-registry*) + (format verbose "~&Added ~A to ASDF.~&" asdf-directory)))) *abcl-contrib*) (format verbose "Failed to find abcl-contrib at '~A'." abcl-contrib)))))) - (when (find-contrib :verbose t) (provide :abcl-contrib)) From ehuelsmann at common-lisp.net Wed Aug 8 21:49:41 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Wed, 08 Aug 2012 14:49:41 -0700 Subject: [armedbear-cvs] r14066 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Aug 8 14:49:40 2012 New Revision: 14066 Log: Fix #168: compilation of LET-PLUS fails. Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Tue Aug 7 23:41:52 2012 (r14065) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Wed Aug 8 14:49:40 2012 (r14066) @@ -492,7 +492,10 @@ ((symbolp place) (multiple-value-bind (expansion expanded) - (expand-macro place) + ;; Expand once in case the form expands + ;; into something that needs special + ;; SETF treatment + (macroexpand-1 place) (if expanded (precompile1 (list* 'SETF expansion (cddr form))) @@ -511,7 +514,10 @@ (val (%cadr args))) (multiple-value-bind (expansion expanded) - (expand-macro sym) + ;; Expand once in case the form expands + ;; into something that needs special + ;; SETF treatment + (macroexpand-1 sym) (if expanded (precompile1 (list 'SETF expansion val)) (list 'SETQ sym (precompile1 val))))) From ehuelsmann at common-lisp.net Thu Aug 9 09:19:41 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 09 Aug 2012 02:19:41 -0700 Subject: [armedbear-cvs] r14067 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Aug 9 02:19:40 2012 New Revision: 14067 Log: Fix declarations being dropped on inline expansions. Report by James M. Lawrence. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Wed Aug 8 14:49:40 2012 (r14066) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Thu Aug 9 02:19:40 2012 (r14067) @@ -528,7 +528,8 @@ ;; FIXME Need to support SETF functions too! (setf (inline-expansion name) (jvm::generate-inline-expansion block-name - lambda-list body)) + lambda-list + (append decls body))) (output-form `(setf (inline-expansion ',name) ',(inline-expansion name)))))) (push name jvm::*functions-defined-in-current-file*) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Wed Aug 8 14:49:40 2012 (r14066) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Thu Aug 9 02:19:40 2012 (r14067) @@ -48,17 +48,26 @@ "Generates code that can be used to expand a named local function inline. It can work either per-function (no args provided) or per-call." (if args-p - (expand-function-call-inline nil lambda-list - (copy-tree `((block ,name , at body))) - args) + (multiple-value-bind + (body decls) + (parse-body body) + (expand-function-call-inline nil lambda-list + ;; the forms below get wrapped + ;; in a LET, making the decls + ;; part of the decls of the LET. + (copy-tree `(, at decls (block ,name , at body))) + args)) (cond ((intersection lambda-list '(&optional &rest &key &allow-other-keys &aux) :test #'eq) nil) (t - (setf body (copy-tree body)) - (list 'LAMBDA lambda-list - (list* 'BLOCK name body)))))) + (multiple-value-bind + (body decls) + (parse-body body) + (setf body (copy-tree body)) + `(lambda ,lambda-list , at decls + (block ,name , at body))))))) ;;; Pass 1. From ehuelsmann at common-lisp.net Thu Aug 9 18:40:47 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 09 Aug 2012 11:40:47 -0700 Subject: [armedbear-cvs] r14068 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Aug 9 11:40:46 2012 New Revision: 14068 Log: Follow up to r14066: expand place in the precompiler environment, which is what the replaced expand-macro call did do correctly. Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Thu Aug 9 02:19:40 2012 (r14067) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Thu Aug 9 11:40:46 2012 (r14068) @@ -495,7 +495,7 @@ ;; Expand once in case the form expands ;; into something that needs special ;; SETF treatment - (macroexpand-1 place) + (macroexpand-1 place *precompile-env*) (if expanded (precompile1 (list* 'SETF expansion (cddr form))) @@ -517,7 +517,7 @@ ;; Expand once in case the form expands ;; into something that needs special ;; SETF treatment - (macroexpand-1 sym) + (macroexpand-1 sym *precompile-env*) (if expanded (precompile1 (list 'SETF expansion val)) (list 'SETQ sym (precompile1 val))))) From ehuelsmann at common-lisp.net Sat Aug 11 09:43:19 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 11 Aug 2012 02:43:19 -0700 Subject: [armedbear-cvs] r14069 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 11 02:43:16 2012 New Revision: 14069 Log: Fix MACROLET expansion error. Reported by Theam Yong Chew. Fix by me. Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Thu Aug 9 11:40:46 2012 (r14068) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Sat Aug 11 02:43:16 2012 (r14069) @@ -443,7 +443,7 @@ (defun precompile-do/do*-end-form (end-form) (let ((end-test-form (car end-form)) (result-forms (cdr end-form))) - (list* end-test-form (mapcar #'precompile1 result-forms)))) + (list* (precompile1 end-test-form) (mapcar #'precompile1 result-forms)))) (defun precompile-do/do* (form) (if *in-jvm-compile* From ehuelsmann at common-lisp.net Sat Aug 11 12:07:53 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 11 Aug 2012 05:07:53 -0700 Subject: [armedbear-cvs] r14070 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 11 05:07:52 2012 New Revision: 14070 Log: Expand types before checking them: fixes Drakma. Patch by Stas Boukarev. Modified: trunk/abcl/src/org/armedbear/lisp/byte-io.lisp trunk/abcl/src/org/armedbear/lisp/read-sequence.lisp trunk/abcl/src/org/armedbear/lisp/write-sequence.lisp Modified: trunk/abcl/src/org/armedbear/lisp/byte-io.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/byte-io.lisp Sat Aug 11 02:43:16 2012 (r14069) +++ trunk/abcl/src/org/armedbear/lisp/byte-io.lisp Sat Aug 11 05:07:52 2012 (r14070) @@ -33,7 +33,7 @@ (defun write-byte (byte stream) (declare (type stream stream)) - (let ((element-type (stream-element-type stream))) + (let ((element-type (expand-deftype (stream-element-type stream)))) (require-type byte element-type) (let ((width (cadr element-type))) (if (= width 8) @@ -48,7 +48,7 @@ (defun read-byte (stream &optional (eof-error-p t) eof-value) (declare (type stream stream)) - (let* ((element-type (stream-element-type stream))) + (let* ((element-type (expand-deftype (stream-element-type stream)))) (unless element-type (if eof-error-p (error 'end-of-file :stream stream) Modified: trunk/abcl/src/org/armedbear/lisp/read-sequence.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/read-sequence.lisp Sat Aug 11 02:43:16 2012 (r14069) +++ trunk/abcl/src/org/armedbear/lisp/read-sequence.lisp Sat Aug 11 05:07:52 2012 (r14070) @@ -37,7 +37,7 @@ (if end (require-type end '(integer 0)) (setf end (length sequence))) - (let* ((element-type (stream-element-type stream))) + (let* ((element-type (expand-deftype (stream-element-type stream)))) (cond ((eq element-type 'character) (do ((pos start (1+ pos))) ((>= pos end) pos) Modified: trunk/abcl/src/org/armedbear/lisp/write-sequence.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/write-sequence.lisp Sat Aug 11 02:43:16 2012 (r14069) +++ trunk/abcl/src/org/armedbear/lisp/write-sequence.lisp Sat Aug 11 05:07:52 2012 (r14070) @@ -45,7 +45,7 @@ :expected-type '(integer 0))) (setf end (length sequence))) (let ((end (the fixnum end)) - (stream-element-type (stream-element-type stream))) + (stream-element-type (expand-deftype (stream-element-type stream)))) (cond ((eq stream-element-type 'character) (if (stringp sequence) (%write-string sequence stream start end) From vvoutilainen at common-lisp.net Sat Aug 11 19:06:03 2012 From: vvoutilainen at common-lisp.net (vvoutilainen at common-lisp.net) Date: Sat, 11 Aug 2012 12:06:03 -0700 Subject: [armedbear-cvs] r14071 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sat Aug 11 12:06:01 2012 New Revision: 14071 Log: correct #195 Modified: trunk/abcl/src/org/armedbear/lisp/top-level.lisp Modified: trunk/abcl/src/org/armedbear/lisp/top-level.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/top-level.lisp Sat Aug 11 05:07:52 2012 (r14070) +++ trunk/abcl/src/org/armedbear/lisp/top-level.lisp Sat Aug 11 12:06:01 2012 (r14071) @@ -389,7 +389,7 @@ (read-line stream) *null-cmd*) (t - (read stream nil))))) + (read stream nil *null-cmd*))))) (defun repl-read-form-fun (in out) (loop From ehuelsmann at common-lisp.net Sun Aug 12 13:26:21 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 12 Aug 2012 06:26:21 -0700 Subject: [armedbear-cvs] r14072 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 12 06:25:58 2012 New Revision: 14072 Log: Make sure the PRINT-OBJECT generic function is loaded when defining methods for it. Modified: trunk/abcl/src/org/armedbear/lisp/defstruct.lisp Modified: trunk/abcl/src/org/armedbear/lisp/defstruct.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/defstruct.lisp Sat Aug 11 12:06:01 2012 (r14071) +++ trunk/abcl/src/org/armedbear/lisp/defstruct.lisp Sun Aug 12 06:25:58 2012 (r14072) @@ -669,6 +669,8 @@ ,@(define-predicate) ,@(define-access-functions) ,@(define-copier) + ,@(when (or *dd-print-function* *dd-print-object*) + `((require "PRINT-OBJECT"))) ,@(define-print-function) ',*dd-name*))) From ehuelsmann at common-lisp.net Sun Aug 12 13:40:24 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 12 Aug 2012 06:40:24 -0700 Subject: [armedbear-cvs] r14073 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 12 06:40:11 2012 New Revision: 14073 Log: Much nicer code printing with (setq jvm::*compiler-debug* t). Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Aug 12 06:25:58 2012 (r14072) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Aug 12 06:40:11 2012 (r14073) @@ -213,7 +213,7 @@ (let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types)) (index (pool-add-method-ref *pool* class-name method-name (cons return-type arg-types))) - (instruction (apply #'%emit 'invokestatic (u2 index)))) + (instruction (%emit 'invokestatic index))) (setf (instruction-stack instruction) stack-effect))) @@ -234,7 +234,7 @@ (let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types)) (index (pool-add-method-ref *pool* class-name method-name (cons return-type arg-types))) - (instruction (apply #'%emit 'invokevirtual (u2 index)))) + (instruction (%emit 'invokevirtual index))) (declare (type (signed-byte 8) stack-effect)) (let ((explain *explain*)) (when (and explain (memq :java-calls explain)) @@ -251,7 +251,7 @@ (let* ((stack-effect (apply #'descriptor-stack-effect :void arg-types)) (index (pool-add-method-ref *pool* class-name "" (cons nil arg-types))) - (instruction (apply #'%emit 'invokespecial (u2 index)))) + (instruction (%emit 'invokespecial index))) (declare (type (signed-byte 8) stack-effect)) (setf (instruction-stack instruction) (1- stack-effect)))) @@ -291,29 +291,29 @@ (defknown emit-getstatic (t t t) t) (defun emit-getstatic (class-name field-name type) (let ((index (pool-add-field-ref *pool* class-name field-name type))) - (apply #'%emit 'getstatic (u2 index)))) + (%emit 'getstatic index))) (defknown emit-putstatic (t t t) t) (defun emit-putstatic (class-name field-name type) (let ((index (pool-add-field-ref *pool* class-name field-name type))) - (apply #'%emit 'putstatic (u2 index)))) + (%emit 'putstatic index))) (declaim (inline emit-getfield emit-putfield)) (defknown emit-getfield (t t t) t) (defun emit-getfield (class-name field-name type) (let* ((index (pool-add-field-ref *pool* class-name field-name type))) - (apply #'%emit 'getfield (u2 index)))) + (%emit 'getfield index))) (defknown emit-putfield (t t t) t) (defun emit-putfield (class-name field-name type) (let* ((index (pool-add-field-ref *pool* class-name field-name type))) - (apply #'%emit 'putfield (u2 index)))) + (%emit 'putfield index))) (defknown emit-new (t) t) (declaim (inline emit-new emit-anewarray emit-checkcast emit-instanceof)) (defun emit-new (class-name) - (apply #'%emit 'new (u2 (pool-class class-name)))) + (%emit 'new (pool-class class-name))) (defknown emit-anewarray (t) t) (defun emit-anewarray (class-name) @@ -321,11 +321,11 @@ (defknown emit-checkcast (t) t) (defun emit-checkcast (class-name) - (apply #'%emit 'checkcast (u2 (pool-class class-name)))) + (apply #'%emit 'checkcast (list (pool-class class-name)))) (defknown emit-instanceof (t) t) (defun emit-instanceof (class-name) - (apply #'%emit 'instanceof (u2 (pool-class class-name)))) + (apply #'%emit 'instanceof (list (pool-class class-name)))) (defvar type-representations '((:int fixnum) @@ -1085,6 +1085,10 @@ (emit 'return)) (with-code-to-method (class (abcl-class-file-static-initializer class)) (emit 'return)) + (when *compiler-debug* + (print "; Writing class file ") + (print (abcl-class-file-class-name class)) + (terpri)) (finalize-class-file class) (write-class-file class stream)) Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sun Aug 12 06:25:58 2012 (r14072) +++ trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sun Aug 12 06:40:11 2012 (r14073) @@ -71,6 +71,29 @@ (:short "S") ((nil :void) "V"))) +(defun pretty-class (type &optional (default-package "")) + (let* ((p-len (1+ (length default-package))) + (len (length type)) + (cnt (when (< p-len len) + (count #\/ type :start p-len))) + (type (if (and cnt (= 0 cnt)) + (subseq type p-len len) + (substitute #\. #\/ type)))) + type)) + +(defun pretty-type (type &optional (default-package "")) + (cond + ((eql #\I type) "int") + ((eql #\J type) "long") + ((eql #\F type) "float") + ((eql #\D type) "double") + ((eql #\Z type) "boolean") + ((eql #\C type) "char") + ((eql #\B type) "byte") + ((eql #\S type) "short") + ((eql #\V type) "void") + ((stringp type) + (pretty-class (subseq type 1 (1- (length type))) default-package)))) #| @@ -265,15 +288,42 @@ (index 0) entries-list ;; the entries hash stores raw values, except in case of string and - ;; utf8, because both are string values + ;; utf8, because both are string values in which case a two-element + ;; list - containing the tag and the value - is used (entries (make-hash-table :test #'equal :size 2048 :rehash-size 2.0))) +(defun matching-index-p (entry index) + (eql (constant-index entry) index)) + +(defun find-pool-entry (pool item &key (test #'matching-index-p)) + (find-if (lambda (x) + (funcall test x item)) + (pool-entries-list pool))) + (defstruct constant "Structure to be included in all constant sub-types." tag index) +(defgeneric print-pool-constant (pool entry stream &key &allow-other-keys) + (:method (pool (entry t) stream &key) + (print-object entry stream))) + +(defmethod print-pool-constant :around (pool entry stream &key recursive) + (cond + ((and (null *print-readably*) + (null *print-escape*) + (null recursive)) + (princ #\# stream) + (princ (constant-index entry) stream) + (princ #\Space stream) + (princ #\< stream) + (call-next-method) + (princ #\> stream)) + (t + (call-next-method)))) + (defparameter +constant-type-map+ '((:class 7 1) (:field-ref 9 1) @@ -293,6 +343,24 @@ "Structure holding information on a 'class' type item in the constant pool." name-index) +(defmethod print-pool-constant (pool (entry constant-class) stream + &key recursive package) + (cond + ((and (null *print-escape*) + (null *print-readably*)) + ;; human readable + (unless recursive + (princ "Class " stream)) + (princ + (pretty-class (constant-utf8-value + (find-pool-entry pool + (constant-class-name-index entry))) + package) + stream)) + (t + ;; READable + (call-next-method)))) + (defstruct (constant-member-ref (:constructor %make-constant-member-ref (tag index class-index name/type-index)) @@ -302,6 +370,39 @@ class-index name/type-index) +(defmethod print-pool-constant (pool (entry constant-member-ref) stream + &key recursive package) + (cond + ((and (null *print-escape*) + (null *print-readably*)) + ;; human readable + (unless recursive + (princ (case (constant-member-ref-tag entry) + (9 "Field ") + (10 "Method ") + (11 "Interface method ")) + stream)) + (let ((name-prefix + (with-output-to-string (s) + (print-pool-constant pool + (find-pool-entry pool + (constant-member-ref-class-index entry)) + s + :recursive t + :package package) + (princ #\. s)))) + (print-pool-constant pool + (find-pool-entry pool + (constant-member-ref-name/type-index entry)) + stream + :name-prefix name-prefix + :recursive t + :package package))) + (t + ;; READable + (call-next-method)))) + + (declaim (inline make-constant-field-ref make-constant-method-ref make-constant-interface-method-ref)) (defun make-constant-field-ref (index class-index name/type-index) @@ -324,6 +425,24 @@ "Structure holding information on a 'string' type item in the constant pool." value-index) + +(defmethod print-pool-constant (pool (entry constant-string) stream + &key recursive) + (cond + ((and (null *print-readably*) + (null *print-escape*)) + (unless recursive + (princ "String " stream)) + (princ #\" stream) + (print-pool-constant pool + (find-pool-entry pool + (constant-string-value-index entry)) + stream + :recursive t) + (princ #\" stream)) + (t + (call-next-method)))) + (defstruct (constant-float/int (:constructor %make-constant-float/int (tag index value)) (:include constant)) @@ -331,6 +450,20 @@ in the constant pool." value) +(defmethod print-pool-constant (pool (entry constant-float/int) stream + &key recursive) + (cond + ((and (null *print-escape*) + (null *print-readably*)) + (unless recursive + (princ (case (constant-tag entry) + (3 "int ") + (4 "float ")) + stream)) + (princ (constant-float/int-value entry) stream)) + (t + (call-next-method)))) + (declaim (inline make-constant-float make-constant-int)) (defun make-constant-float (index value) "Creates a `constant-float/int' structure instance containing a float." @@ -347,6 +480,20 @@ in the constant pool." value) +(defmethod print-pool-constant (pool (entry constant-double/long) stream + &key recursive) + (cond + ((and (null *print-escape*) + (null *print-readably*)) + (unless recursive + (princ (case (constant-tag entry) + (5 "long ") + (6 "double ")) + stream)) + (princ (constant-double/long-value entry) stream)) + (t + (call-next-method)))) + (declaim (inline make-constant-double make-constant-float)) (defun make-constant-double (index value) "Creates a `constant-double/long' structure instance containing a double." @@ -367,6 +514,59 @@ name-index descriptor-index) +(defun parse-descriptor (descriptor) + (let (arguments + method-descriptor-p + (index 0)) + (when (eql (aref descriptor 0) #\() + ;; parse the arguments here... + (assert (find #\) descriptor)) + (setf method-descriptor-p t) + (loop until (eql (aref descriptor index) #\)) + do (incf index) + if (find (aref descriptor index) "IJFDZCBSV") + do (push (aref descriptor index) arguments) + if (eql (aref descriptor index) #\L) + do (loop for i upfrom index + until (eql (aref descriptor i) #\;) + finally (push (subseq descriptor index (1+ i)) + arguments) + finally (setf index i)) + finally (incf index))) + (values (let ((return-value (subseq descriptor index))) + (if (= (length return-value) 1) + (aref return-value 0) + return-value)) + (nreverse arguments) + method-descriptor-p))) + +(defmethod print-pool-constant (pool (entry constant-name/type) stream + &key name-prefix package) + (cond + ((and (null *print-readably*) + (null *print-escape*)) + (multiple-value-bind + (type arguments method-descriptor-p) + (let ((entry (find-pool-entry pool + (constant-name/type-descriptor-index entry)))) + (if (constant-utf8-p entry) + (parse-descriptor (constant-utf8-value entry)) + (class-ref entry))) + (princ (pretty-type type package) stream) + (princ #\Space stream) + (when name-prefix + (princ name-prefix stream)) + (print-pool-constant pool + (find-pool-entry pool (constant-name/type-name-index entry)) + stream + :recursive t) + (when method-descriptor-p + (format stream "(~{~A~^,~})" (mapcar (lambda (x) + (pretty-type x package)) + arguments))))) + (t + (call-next-method)))) + (defstruct (constant-utf8 (:constructor make-constant-utf8 (index value)) (:include constant (tag 1))) @@ -762,7 +962,7 @@ (incf pool-index) (let ((tag (constant-tag entry))) (when *jvm-class-debug-pool* - (print-constant entry t)) + (print-entry entry t)) (write-u1 tag stream) (case tag (1 ; UTF8 @@ -788,7 +988,7 @@ (error "write-constant-pool-entry unhandled tag ~D~%" tag))))))) -(defun print-constant (entry stream) +(defun print-entry (entry stream) "Debugging helper to print the content of a constant-pool entry." (let ((tag (constant-tag entry)) (index (constant-index entry))) @@ -807,6 +1007,13 @@ (8 (sys::%format t "str: ~a~%" (constant-string-value-index entry)))))) +(defmethod print-pool-constant (pool (entry constant-utf8) stream &key) + (if (and (null *print-escape*) + (null *print-readably*)) + (princ (constant-utf8-value entry) stream) + (call-next-method))) + + #| ABCL doesn't use interfaces, so don't implement it here at this time @@ -1043,7 +1250,8 @@ (nconc (mapcar #'exception-start-pc handlers) (mapcar #'exception-end-pc handlers) (mapcar #'exception-handler-pc handlers)) - (code-optimize code)))) + (code-optimize code) + (class-file-constants class)))) (invoke-callbacks :code-finalized class parent (coerce c 'list) handlers) (unless (code-max-stack code) @@ -1055,6 +1263,7 @@ (multiple-value-bind (c labels) (code-bytes c) + (assert (< 0 (length c) 65536)) (setf (code-code code) c (code-labels code) labels))) Modified: trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Sun Aug 12 06:25:58 2012 (r14072) +++ trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Sun Aug 12 06:40:11 2012 (r14073) @@ -448,17 +448,34 @@ (and instruction (= (the fixnum (instruction-opcode (the instruction instruction))) 202))) -(defun print-code (code) +(defun format-instruction-args (instruction pool) + (if (memql (instruction-opcode instruction) '(18 19 20 + 178 179 180 181 182 183 184 185 + 187 + 192 193)) + (let ((*print-readably* nil) + (*print-escape* nil)) + (with-output-to-string (s) + (print-pool-constant pool + (find-pool-entry pool + (car (instruction-args instruction))) s + :package "org/armedbear/lisp"))) + (when (instruction-args instruction) + (format nil "~S" (instruction-args instruction))))) + +(defun print-code (code pool) + (declare (ignorable pool)) (dotimes (i (length code)) (let ((instruction (elt code i))) - (sys::%format t "~D ~A ~S ~S ~S~%" + (format t "~3D ~A ~19T~A ~A ~A~%" i (opcode-name (instruction-opcode instruction)) - (instruction-args instruction) - (instruction-stack instruction) - (instruction-depth instruction))))) + (or (format-instruction-args instruction pool) "") + (or (instruction-stack instruction) "") + (or (instruction-depth instruction) ""))))) -(defun print-code2 (code) +(defun print-code2 (code pool) + (declare (ignorable pool)) (dotimes (i (length code)) (let ((instruction (elt code i))) (case (instruction-opcode instruction) @@ -482,8 +499,8 @@ (list (inst 'aload (car (instruction-args instruction))) (inst 'aconst_null) - (inst 'putfield (u2 (pool-field +lisp-thread+ "_values" - +lisp-object-array+))))) + (inst 'putfield (list (pool-field +lisp-thread+ "_values" + +lisp-object-array+))))) (vector-push-extend instruction vector))) (t (vector-push-extend instruction vector))))))) @@ -602,19 +619,9 @@ 172 ; ireturn 176 ; areturn 177 ; return - 178 ; getstatic - 179 ; putstatic - 180 ; getfield - 181 ; putfield - 182 ; invokevirtual - 183 ; invockespecial - 184 ; invokestatic - 187 ; new 189 ; anewarray 190 ; arraylength 191 ; athrow - 192 ; checkcast - 193 ; instanceof 194 ; monitorenter 195 ; monitorexit 198 ; ifnull @@ -715,6 +722,13 @@ (error "IINC argument ~A out of bounds." n)) (inst 132 (list register (s1 n))))) +(define-resolver (178 179 180 181 182 183 184 185 192 193 187) + (instruction) + (let* ((arg (car (instruction-args instruction)))) + (setf (instruction-args instruction) + (u2 arg)) + instruction)) + (defknown resolve-instruction (t) t) (defun resolve-instruction (instruction) (declare (optimize speed)) @@ -970,13 +984,13 @@ (defvar *enable-optimization* t) (defknown optimize-code (t t) t) -(defun optimize-code (code handler-labels) +(defun optimize-code (code handler-labels pool) (unless *enable-optimization* (format t "optimizations are disabled~%")) (when *enable-optimization* (when *compiler-debug* (format t "----- before optimization -----~%") - (print-code code)) + (print-code code pool)) (loop (let ((changed-p nil)) (multiple-value-setq @@ -1003,7 +1017,7 @@ (setf code (coerce code 'vector))) (when *compiler-debug* (sys::%format t "----- after optimization -----~%") - (print-code code))) + (print-code code pool))) code) @@ -1036,6 +1050,7 @@ (offset (- (the (unsigned-byte 16) (symbol-value (the symbol label))) index))) + (assert (<= -32768 offset 32767)) (setf (instruction-args instruction) (s2 offset)))) (unless (= (instruction-opcode instruction) 202) ; LABEL (incf index (opcode-size (instruction-opcode instruction))))))) @@ -1054,10 +1069,10 @@ (incf index))))) (values bytes labels)))) -(defun finalize-code (code handler-labels optimize) +(defun finalize-code (code handler-labels optimize pool) (setf code (coerce (nreverse code) 'vector)) (when optimize - (setf code (optimize-code code handler-labels))) + (setf code (optimize-code code handler-labels pool))) (resolve-instructions (expand-virtual-instructions code))) (provide '#:opcodes) From ehuelsmann at common-lisp.net Sun Aug 12 19:57:54 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 12 Aug 2012 12:57:54 -0700 Subject: [armedbear-cvs] r14074 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 12 12:57:53 2012 New Revision: 14074 Log: Flatten (and simplify) AND and OR compilation. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Aug 12 06:40:11 2012 (r14073) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Aug 12 12:57:53 2012 (r14074) @@ -6192,30 +6192,23 @@ (emit-move-from-stack target representation)) (1 (compile-form (%car args) target representation)) - (2 - (let ((arg1 (%car args)) - (arg2 (%cadr args)) - (FAIL (gensym)) - (DONE (gensym))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :boolean) - (emit 'ifeq FAIL) - (ecase representation - (:boolean - (compile-forms-and-maybe-emit-clear-values arg2 'stack :boolean) - (emit 'goto DONE) - (label FAIL) - (emit 'iconst_0)) - ((nil) - (compile-form arg2 'stack nil) - (emit 'goto DONE) - (label FAIL) - (emit-push-nil))) - (label DONE) - (emit-move-from-stack target representation))) (t - ;; (and a b c d e f) => (and a (and b c d e f)) - (let ((new-form `(and ,(%car args) (and ,@(%cdr args))))) - (p2-and new-form target representation)))))) + (let ((FAIL (gensym)) + (DONE (gensym)) + (butlast-args (butlast args))) + (loop + for form in butlast-args + do (compile-form form 'stack nil) + do (emit-push-nil) + do (emit 'if_acmpeq FAIL)) + (apply #'maybe-emit-clear-values butlast-args) + (compile-form (car (last args)) target representation) + (emit 'goto DONE) + (label FAIL) + (apply #'maybe-emit-clear-values butlast-args) + (emit-push-false representation) + (emit-move-from-stack target representation) + (label DONE)))))) (defknown p2-or (t t t) t) (defun p2-or (form target representation) @@ -6226,26 +6219,25 @@ (emit-move-from-stack target representation)) (1 (compile-form (%car args) target representation)) - (2 - (let ((arg1 (%car args)) - (arg2 (%cadr args)) - (LABEL1 (gensym)) - (LABEL2 (gensym))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) - (emit 'dup) - (emit-push-nil) - (emit 'if_acmpne LABEL1) - (emit 'pop) - (compile-form arg2 'stack representation) - (emit 'goto LABEL2) - (label LABEL1) - (fix-boxing representation nil) ; FIXME use derived result type - (label LABEL2) - (emit-move-from-stack target representation))) (t - ;; (or a b c d e f) => (or a (or b c d e f)) - (let ((new-form `(or ,(%car args) (or ,@(%cdr args))))) - (p2-or new-form target representation)))))) + (let ((SUCCESS (gensym)) + (DONE (gensym)) + (butlast-args (butlast args))) + (loop + for form in butlast-args + do (compile-form form 'stack nil) + do (emit 'dup) ;; leave value on the stack for SUCCESS to use + do (emit-push-nil) + do (emit 'if_acmpne SUCCESS) + do (emit 'pop)) + (apply #'maybe-emit-clear-values butlast-args) + (compile-form (car (last args)) target representation) + (emit 'goto DONE) + (label SUCCESS) + (fix-boxing representation nil) ;; value is still on the stack + (emit-move-from-stack target representation) + (apply #'maybe-emit-clear-values butlast-args) + (label DONE)))))) (defun p2-values (form target representation) (let* ((args (cdr form)) From ehuelsmann at common-lisp.net Sun Aug 12 20:42:50 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 12 Aug 2012 13:42:50 -0700 Subject: [armedbear-cvs] r14075 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 12 13:42:48 2012 New Revision: 14075 Log: Fix #214: NOTINLINE declaration in expansion of compiler macro is ignored. Note: The truth be told, but all optimization declarations (inline/ notinnline) were ignored in pass1, except in some rare cases. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun Aug 12 12:57:53 2012 (r14074) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun Aug 12 13:42:48 2012 (r14075) @@ -489,10 +489,12 @@ ;; Make free specials visible. (dolist (variable (let-free-specials block)) (push variable *visible-variables*))) - (let ((*blocks* (cons block *blocks*))) - (setf body (p1-body body))) - (setf (let-form block) (list* op varlist body)) - block)) + (with-saved-compiler-policy + (process-optimization-declarations body) + (let ((*blocks* (cons block *blocks*))) + (setf body (p1-body body))) + (setf (let-form block) (list* op varlist body)) + block))) (defun p1-locally (form) (let* ((*visible-variables* *visible-variables*) @@ -504,9 +506,11 @@ ;; (format t "p1-locally ~S is special~%" name) (push special *visible-variables*)) (let ((*blocks* (cons block *blocks*))) - (setf (locally-form block) - (list* 'LOCALLY (p1-body (cdr form)))) - block))) + (with-saved-compiler-policy + (process-optimization-declarations (cdr form)) + (setf (locally-form block) + (list* 'LOCALLY (p1-body (cdr form)))) + block)))) (defknown p1-m-v-b (t) t) (defun p1-m-v-b (form) @@ -538,10 +542,12 @@ (dolist (special (m-v-b-free-specials block)) (push special *visible-variables*)) (setf (m-v-b-vars block) (nreverse vars))) - (setf body (p1-body body)) - (setf (m-v-b-form block) - (list* 'MULTIPLE-VALUE-BIND varlist values-form body)) - block)) + (with-saved-compiler-policy + (process-optimization-declarations body) + (setf body (p1-body body)) + (setf (m-v-b-form block) + (list* 'MULTIPLE-VALUE-BIND varlist values-form body)) + block))) (defun p1-block (form) (let* ((block (make-block-node (cadr form))) @@ -956,9 +962,11 @@ (process-declarations-for-vars body nil block)) (dolist (special (labels-free-specials block)) (push special *visible-variables*)) - (setf (labels-form block) - (list* (car form) local-functions (p1-body (cddr form)))) - block))) + (with-saved-compiler-policy + (process-optimization-declarations (cddr form)) + (setf (labels-form block) + (list* (car form) local-functions (p1-body (cddr form)))) + block)))) (defknown p1-funcall (t) t) (defun p1-funcall (form) From ehuelsmann at common-lisp.net Mon Aug 13 06:22:14 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 12 Aug 2012 23:22:14 -0700 Subject: [armedbear-cvs] r14076 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 12 23:22:13 2012 New Revision: 14076 Log: Set function slot for CL:LISTEN when hooking up gray streams. Patch by Stas Boukarev. Modified: trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp Modified: trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp Sun Aug 12 13:42:48 2012 (r14075) +++ trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp Sun Aug 12 23:22:13 2012 (r14076) @@ -156,7 +156,7 @@ (defvar *ansi-read-char* #'read-char) (defvar *ansi-peek-char* #'peek-char) (defvar *ansi-unread-char* #'unread-char) -(defvar *ansi-listen* nil) +(defvar *ansi-listen* #'listen) (defvar *ansi-read-line* #'read-line) (defvar *ansi-read-char-no-hang* #'read-char-no-hang) (defvar *ansi-write-char* #'write-char) @@ -639,7 +639,7 @@ (setf (symbol-function 'common-lisp::read-sequence) #'gray-read-sequence) (setf (symbol-function 'common-lisp::write-sequence) #'gray-write-sequence) (setf (symbol-function 'common-lisp::file-position) #'gray-file-position) - +(setf (symbol-function 'common-lisp::listen) #'gray-listen) #| (setf (symbol-function 'common-lisp::make-two-way-stream) #'gray-make-two-way-stream) (setf (symbol-function 'common-lisp::two-way-stream-input-stream) #'gray-two-way-stream-input-stream) From ehuelsmann at common-lisp.net Mon Aug 13 08:29:28 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Mon, 13 Aug 2012 01:29:28 -0700 Subject: [armedbear-cvs] r14077 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Aug 13 01:29:26 2012 New Revision: 14077 Log: Untabify. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun Aug 12 23:22:13 2012 (r14076) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Mon Aug 13 01:29:26 2012 (r14077) @@ -165,151 +165,151 @@ (defun match-lambda-list (parsed-lambda-list arguments) (flet ((pop-required-argument () - (if (null arguments) - (error 'lambda-list-mismatch :mismatch-type :too-few-arguments) - (pop arguments))) - (var (var-info) (car var-info)) - (initform (var-info) (cadr var-info)) - (p-var (var-info) (caddr var-info))) + (if (null arguments) + (error 'lambda-list-mismatch :mismatch-type :too-few-arguments) + (pop arguments))) + (var (var-info) (car var-info)) + (initform (var-info) (cadr var-info)) + (p-var (var-info) (caddr var-info))) (destructuring-bind (req opt key key-p rest allow-others-p aux whole env) - parsed-lambda-list + parsed-lambda-list (declare (ignore whole env)) (let (req-bindings temp-bindings bindings ignorables) - ;;Required arguments. - (setf req-bindings - (loop :for var :in req :collect `(,var ,(pop-required-argument)))) - - ;;Optional arguments. - (when opt - (dolist (var-info opt) - (if arguments - (progn - (push-argument-binding (var var-info) (pop arguments) - temp-bindings bindings) - (when (p-var var-info) - (push `(,(p-var var-info) t) bindings))) - (progn - (push `(,(var var-info) ,(initform var-info)) bindings) - (when (p-var var-info) - (push `(,(p-var var-info) nil) bindings))))) - (setf bindings (nreverse bindings))) - - (unless (or key-p rest (null arguments)) - (error 'lambda-list-mismatch :mismatch-type :too-many-arguments)) - - ;;Keyword and rest arguments. - (if key-p - (multiple-value-bind (kbindings ktemps kignor) - (match-keyword-and-rest-args - key allow-others-p rest arguments) - (setf bindings (append bindings kbindings) - temp-bindings (append temp-bindings ktemps) - ignorables (append kignor ignorables))) - (when rest - (let (rest-binding) - (push-argument-binding (var rest) `(list , at arguments) - temp-bindings rest-binding) - (setf bindings (append bindings rest-binding))))) - ;;Aux parameters. - (when aux - (setf bindings - `(, at bindings - ,@(loop - :for var-info :in aux - :collect `(,(var var-info) ,(initform var-info)))))) - (values (append req-bindings temp-bindings bindings) - ignorables))))) + ;;Required arguments. + (setf req-bindings + (loop :for var :in req :collect `(,var ,(pop-required-argument)))) + + ;;Optional arguments. + (when opt + (dolist (var-info opt) + (if arguments + (progn + (push-argument-binding (var var-info) (pop arguments) + temp-bindings bindings) + (when (p-var var-info) + (push `(,(p-var var-info) t) bindings))) + (progn + (push `(,(var var-info) ,(initform var-info)) bindings) + (when (p-var var-info) + (push `(,(p-var var-info) nil) bindings))))) + (setf bindings (nreverse bindings))) + + (unless (or key-p rest (null arguments)) + (error 'lambda-list-mismatch :mismatch-type :too-many-arguments)) + + ;;Keyword and rest arguments. + (if key-p + (multiple-value-bind (kbindings ktemps kignor) + (match-keyword-and-rest-args + key allow-others-p rest arguments) + (setf bindings (append bindings kbindings) + temp-bindings (append temp-bindings ktemps) + ignorables (append kignor ignorables))) + (when rest + (let (rest-binding) + (push-argument-binding (var rest) `(list , at arguments) + temp-bindings rest-binding) + (setf bindings (append bindings rest-binding))))) + ;;Aux parameters. + (when aux + (setf bindings + `(, at bindings + ,@(loop + :for var-info :in aux + :collect `(,(var var-info) ,(initform var-info)))))) + (values (append req-bindings temp-bindings bindings) + ignorables))))) (defun match-keyword-and-rest-args (key allow-others-p rest arguments) (flet ((var (var-info) (car var-info)) - (initform (var-info) (cadr var-info)) - (p-var (var-info) (caddr var-info)) - (keyword (var-info) (cadddr var-info))) + (initform (var-info) (cadr var-info)) + (p-var (var-info) (caddr var-info)) + (keyword (var-info) (cadddr var-info))) (when (oddp (list-length arguments)) (error 'lambda-list-mismatch - :mismatch-type :odd-number-of-keyword-arguments)) + :mismatch-type :odd-number-of-keyword-arguments)) (let (temp-bindings bindings other-keys-found-p ignorables already-seen - args) + args) ;;If necessary, make up a fake argument to hold :allow-other-keys, ;;needed later. This also handles nicely: ;; 3.4.1.4.1 Suppressing Keyword Argument Checking ;;third statement. (unless (find :allow-other-keys key :key #'keyword) - (let ((allow-other-keys-temp (gensym (symbol-name :allow-other-keys)))) - (push allow-other-keys-temp ignorables) - (push (list allow-other-keys-temp nil nil :allow-other-keys) key))) + (let ((allow-other-keys-temp (gensym (symbol-name :allow-other-keys)))) + (push allow-other-keys-temp ignorables) + (push (list allow-other-keys-temp nil nil :allow-other-keys) key))) ;;First, let's bind the keyword arguments that have been passed by ;;the caller. If we encounter an unknown keyword, remember it. ;;As per the above, :allow-other-keys will never be considered ;;an unknown keyword. (loop - :for var :in arguments :by #'cddr - :for value :in (cdr arguments) :by #'cddr - :do (let ((var-info (find var key :key #'keyword))) - (if (and var-info (not (member var already-seen))) - ;;var is one of the declared keyword arguments - (progn - (push-argument-binding (var var-info) value - temp-bindings bindings) - (when (p-var var-info) - (push `(,(p-var var-info) t) bindings)) - (push var args) - (push (var var-info) args) - (push var already-seen)) - (let ((g (gensym))) - (push `(,g ,value) temp-bindings) - (push var args) - (push g args) - (push g ignorables) - (unless var-info - (setf other-keys-found-p t)))))) + :for var :in arguments :by #'cddr + :for value :in (cdr arguments) :by #'cddr + :do (let ((var-info (find var key :key #'keyword))) + (if (and var-info (not (member var already-seen))) + ;;var is one of the declared keyword arguments + (progn + (push-argument-binding (var var-info) value + temp-bindings bindings) + (when (p-var var-info) + (push `(,(p-var var-info) t) bindings)) + (push var args) + (push (var var-info) args) + (push var already-seen)) + (let ((g (gensym))) + (push `(,g ,value) temp-bindings) + (push var args) + (push g args) + (push g ignorables) + (unless var-info + (setf other-keys-found-p t)))))) ;;Then, let's bind those arguments that haven't been passed in ;;to their default value, in declaration order. (let (defaults) - (loop - :for var-info :in key - :do (unless (find (var var-info) bindings :key #'car) - (push `(,(var var-info) ,(initform var-info)) defaults) - (when (p-var var-info) - (push `(,(p-var var-info) nil) defaults)))) - (setf bindings (append (nreverse defaults) bindings))) + (loop + :for var-info :in key + :do (unless (find (var var-info) bindings :key #'car) + (push `(,(var var-info) ,(initform var-info)) defaults) + (when (p-var var-info) + (push `(,(p-var var-info) nil) defaults)))) + (setf bindings (append (nreverse defaults) bindings))) ;;If necessary, check for unrecognized keyword arguments. (when (and other-keys-found-p (not allow-others-p)) - (if (loop - :for var :in arguments :by #'cddr - :if (eq var :allow-other-keys) - :do (return t)) - ;;We know that :allow-other-keys has been passed, so we - ;;can access the binding for it and be sure to get the - ;;value passed by the user and not an initform. - (let* ((arg (var (find :allow-other-keys key :key #'keyword))) - (binding (find arg bindings :key #'car)) - (form (cadr binding))) - (if (constantp form) - (unless (eval form) - (error 'lambda-list-mismatch - :mismatch-type :unknown-keyword)) - (setf (cadr binding) - `(or ,(cadr binding) - (error 'program-error - "Unrecognized keyword argument"))))) - ;;TODO: it would be nice to report *which* keyword - ;;is unknown - (error 'lambda-list-mismatch :mismatch-type :unknown-keyword))) + (if (loop + :for var :in arguments :by #'cddr + :if (eq var :allow-other-keys) + :do (return t)) + ;;We know that :allow-other-keys has been passed, so we + ;;can access the binding for it and be sure to get the + ;;value passed by the user and not an initform. + (let* ((arg (var (find :allow-other-keys key :key #'keyword))) + (binding (find arg bindings :key #'car)) + (form (cadr binding))) + (if (constantp form) + (unless (eval form) + (error 'lambda-list-mismatch + :mismatch-type :unknown-keyword)) + (setf (cadr binding) + `(or ,(cadr binding) + (error 'program-error + "Unrecognized keyword argument"))))) + ;;TODO: it would be nice to report *which* keyword + ;;is unknown + (error 'lambda-list-mismatch :mismatch-type :unknown-keyword))) (when rest - (setf bindings (append bindings `((,(var rest) (list ,@(nreverse args))))))) + (setf bindings (append bindings `((,(var rest) (list ,@(nreverse args))))))) (values bindings temp-bindings ignorables)))) #||test for the above (handler-case (let ((lambda-list - (multiple-value-list - (jvm::parse-lambda-list - '(a b &optional (c 42) &rest foo &key (bar c) baz ((kaz kuz) bar)))))) + (multiple-value-list + (jvm::parse-lambda-list + '(a b &optional (c 42) &rest foo &key (bar c) baz ((kaz kuz) bar)))))) (jvm::match-lambda-list lambda-list '((print 1) 3 (print 32) :bar 2))) @@ -319,16 +319,16 @@ (defun expand-function-call-inline (form lambda-list body args) (handler-case (multiple-value-bind (bindings ignorables) - (match-lambda-list (multiple-value-list - (parse-lambda-list lambda-list)) - args) - `(let* ,bindings - ,@(when ignorables - `((declare (ignorable , at ignorables)))) - , at body)) + (match-lambda-list (multiple-value-list + (parse-lambda-list lambda-list)) + args) + `(let* ,bindings + ,@(when ignorables + `((declare (ignorable , at ignorables)))) + , at body)) (lambda-list-mismatch (x) (compiler-warn "Invalid function call: ~S (mismatch type: ~A)" - form (lambda-list-mismatch-type x)) + form (lambda-list-mismatch-type x)) form))) ;; Returns a list of declared free specials, if any are found. @@ -408,31 +408,31 @@ (defmacro p1-let/let*-vars (block varlist variables-var var body1 body2) (let ((varspec (gensym)) - (initform (gensym)) - (name (gensym))) + (initform (gensym)) + (name (gensym))) `(let ((,variables-var ())) (dolist (,varspec ,varlist) - (cond ((consp ,varspec) + (cond ((consp ,varspec) ;; Even though the precompiler already signals this ;; error, double checking can't hurt; after all, we're ;; also rewriting &AUX into LET* bindings. - (unless (<= 1 (length ,varspec) 2) - (compiler-error "The LET/LET* binding specification ~S is invalid." - ,varspec)) - (let* ((,name (%car ,varspec)) - (,initform (p1 (%cadr ,varspec))) - (,var (make-variable :name (check-name ,name) + (unless (<= 1 (length ,varspec) 2) + (compiler-error "The LET/LET* binding specification ~S is invalid." + ,varspec)) + (let* ((,name (%car ,varspec)) + (,initform (p1 (%cadr ,varspec))) + (,var (make-variable :name (check-name ,name) :initform ,initform :block ,block))) - (when (neq ,initform (cadr ,varspec)) - (setf (cadr ,varspec) ,initform)) - (push ,var ,variables-var) - , at body1)) - (t - (let ((,var (make-variable :name (check-name ,varspec) + (when (neq ,initform (cadr ,varspec)) + (setf (cadr ,varspec) ,initform)) + (push ,var ,variables-var) + , at body1)) + (t + (let ((,var (make-variable :name (check-name ,varspec) :block ,block))) - (push ,var ,variables-var) - , at body1)))) + (push ,var ,variables-var) + , at body1)))) , at body2))) (defknown p1-let-vars (t) t) @@ -458,7 +458,7 @@ (declare (type cons form)) (let* ((*visible-variables* *visible-variables*) (block (make-let/let*-node)) - (*block* block) + (*block* block) (op (%car form)) (varlist (cadr form)) (body (cddr form))) @@ -499,7 +499,7 @@ (defun p1-locally (form) (let* ((*visible-variables* *visible-variables*) (block (make-locally-node)) - (*block* block) + (*block* block) (free-specials (process-declarations-for-vars (cdr form) nil block))) (setf (locally-free-specials block) free-specials) (dolist (special free-specials) @@ -519,7 +519,7 @@ (return-from p1-m-v-b (p1-let/let* new-form)))) (let* ((*visible-variables* *visible-variables*) (block (make-m-v-b-node)) - (*block* block) + (*block* block) (varlist (cadr form)) ;; Process the values-form first. ("The scopes of the name binding and ;; declarations do not include the values-form.") @@ -551,7 +551,7 @@ (defun p1-block (form) (let* ((block (make-block-node (cadr form))) - (*block* block) + (*block* block) (*blocks* (cons block *blocks*))) (setf (cddr form) (p1-body (cddr form))) (setf (block-form block) form) @@ -568,7 +568,7 @@ (let* ((tag (p1 (cadr form))) (body (cddr form)) (block (make-catch-node)) - (*block* block) + (*block* block) ;; our subform processors need to know ;; they're enclosed in a CATCH block (*blocks* (cons block *blocks*)) @@ -592,7 +592,7 @@ (let* ((synchronized-object (p1 (cadr form))) (body (cddr form)) (block (make-synchronized-node)) - (*block* block) + (*block* block) (*blocks* (cons block *blocks*)) result) (dolist (subform body) @@ -616,7 +616,7 @@ ;; However, p1 transforms the forms being processed, so, we ;; need to copy the forms to create a second copy. (let* ((block (make-unwind-protect-node)) - (*block* block) + (*block* block) ;; a bit of jumping through hoops... (unwinding-forms (p1-body (copy-tree (cddr form)))) (unprotected-forms (p1-body (cddr form))) @@ -667,7 +667,7 @@ (defun p1-tagbody (form) (let* ((block (make-tagbody-node)) - (*block* block) + (*block* block) (*blocks* (cons block *blocks*)) (*visible-tags* *visible-tags*) (local-tags '()) @@ -1058,7 +1058,7 @@ (let* ((symbols-form (p1 (cadr form))) (values-form (p1 (caddr form))) (block (make-progv-node)) - (*block* block) + (*block* block) (*blocks* (cons block *blocks*)) (body (cdddr form))) ;; The (commented out) block below means to detect compile-time @@ -1316,7 +1316,7 @@ (UNWIND-PROTECT p1-unwind-protect) (THREADS:SYNCHRONIZED-ON p1-threads-synchronized-on) - (JVM::WITH-INLINE-CODE identity))) + (JVM::WITH-INLINE-CODE identity))) (install-p1-handler (%car pair) (%cadr pair)))) (initialize-p1-handlers) From ehuelsmann at common-lisp.net Mon Aug 13 11:34:20 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Mon, 13 Aug 2012 04:34:20 -0700 Subject: [armedbear-cvs] r14078 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Aug 13 04:34:07 2012 New Revision: 14078 Log: Re #236: Solve the EVAL part of "Bad error message for malformed forms". Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java Mon Aug 13 01:29:26 2012 (r14077) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Mon Aug 13 04:34:07 2012 (r14078) @@ -520,7 +520,7 @@ } else { - if (first.car() == Symbol.LAMBDA) + if (first instanceof Cons && first.car() == Symbol.LAMBDA) { Closure closure = new Closure(first, env); return evalCall(closure, ((Cons)obj).cdr, env, thread); From rschlatte at common-lisp.net Mon Aug 13 13:22:19 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Mon, 13 Aug 2012 06:22:19 -0700 Subject: [armedbear-cvs] r14079 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Mon Aug 13 06:22:17 2012 New Revision: 14079 Log: Don't overwrite existing attributes in ensure-generic-function - also add initargs :method-combination, :documentation for generic functions Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Mon Aug 13 04:34:07 2012 (r14078) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Mon Aug 13 06:22:17 2012 (r14079) @@ -865,7 +865,31 @@ STANDARD_OBJECT, BuiltInClass.FUNCTION, BuiltInClass.CLASS_T); - STANDARD_GENERIC_FUNCTION.setDirectSlotDefinitions(STANDARD_GENERIC_FUNCTION.getClassLayout().generateSlotDefinitions()); + STANDARD_GENERIC_FUNCTION.setDirectSlotDefinitions( + list(new SlotDefinition(PACKAGE_SYS.intern("NAME"), NIL, constantlyNil), + new SlotDefinition(PACKAGE_SYS.intern("LAMBDA-LIST"), NIL, + constantlyNil), + new SlotDefinition(PACKAGE_SYS.intern("REQUIRED-ARGS"), NIL, + constantlyNil), + new SlotDefinition(PACKAGE_SYS.intern("OPTIONAL-ARGS"), NIL, + constantlyNil), + new SlotDefinition(PACKAGE_SYS.intern("INITIAL-METHODS"), NIL, + constantlyNil), + new SlotDefinition(PACKAGE_SYS.intern("METHODS"), NIL, + constantlyNil), + new SlotDefinition(PACKAGE_SYS.intern("METHOD-CLASS"), NIL, + constantlyNil), + new SlotDefinition(PACKAGE_SYS.intern("%METHOD-COMBINATION"), NIL, + constantlyNil, + list(internKeyword("METHOD-COMBINATION"))), + new SlotDefinition(PACKAGE_SYS.intern("ARGUMENT-PRECEDENCE-ORDER"), + NIL, constantlyNil), + new SlotDefinition(PACKAGE_SYS.intern("DECLARATIONS"), NIL, + constantlyNil), + new SlotDefinition(PACKAGE_SYS.intern("CLASSES-TO-EMF-TABLE"), NIL, + constantlyNil), + new SlotDefinition(Symbol._DOCUMENTATION, NIL, constantlyNil, + list(internKeyword("DOCUMENTATION"))))); // There are no inherited slots. STANDARD_GENERIC_FUNCTION.setSlotDefinitions(STANDARD_GENERIC_FUNCTION.getDirectSlotDefinitions()); } Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Aug 13 04:34:07 2012 (r14078) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Aug 13 06:22:17 2012 (r14079) @@ -4493,10 +4493,10 @@ ((generic-function generic-function) function-name &rest all-keys - &key (generic-function-class +the-standard-generic-function-class+) + &key (generic-function-class (class-of generic-function)) (lambda-list nil lambda-list-supplied-p) - (method-class +the-standard-method-class+) - (method-combination +the-standard-method-combination+) + (method-class (generic-function-method-class generic-function)) + (method-combination (generic-function-method-combination generic-function)) &allow-other-keys) (setf all-keys (copy-list all-keys)) ; since we modify it (remf all-keys :generic-function-class) From rschlatte at common-lisp.net Mon Aug 13 16:04:39 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Mon, 13 Aug 2012 09:04:39 -0700 Subject: [armedbear-cvs] r14080 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Mon Aug 13 09:04:38 2012 New Revision: 14080 Log: Don't spuriously generate generic functions. - slight deviation from AMOP since we hand make-method-lambda an uninitialized generic-function object. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Aug 13 06:22:17 2012 (r14079) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Aug 13 09:04:38 2012 (r14080) @@ -2796,7 +2796,7 @@ (let* ((specializers-form '()) (lambda-expression `(lambda ,lambda-list , at declarations ,body)) (gf (or (find-generic-function function-name nil) - (ensure-generic-function function-name :lambda-list lambda-list))) + (class-prototype (find-class 'standard-generic-function)))) (method-function (make-method-lambda gf (class-prototype (generic-function-method-class gf)) lambda-expression env)) From ehuelsmann at common-lisp.net Tue Aug 14 08:01:44 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 14 Aug 2012 01:01:44 -0700 Subject: [armedbear-cvs] r14081 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Aug 14 01:01:40 2012 New Revision: 14081 Log: Re #236: prepare to offer restarts from inside the compiler. Note: Restarts, when used to replace forms, need to be in pass1 because that's where we inject variable references, etc. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Mon Aug 13 09:04:38 2012 (r14080) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Tue Aug 14 01:01:40 2012 (r14081) @@ -977,17 +977,9 @@ (when (and (consp function-form) (eq (%car function-form) 'FUNCTION)) (let ((name (%cadr function-form))) -;; (format t "p1-funcall name = ~S~%" name) (let ((source-transform (source-transform name))) (when source-transform -;; (format t "found source transform for ~S~%" name) -;; (format t "old form = ~S~%" form) -;; (let ((new-form (expand-source-transform form))) -;; (when (neq new-form form) -;; (format t "new form = ~S~%" new-form) -;; (return-from p1-funcall (p1 new-form)))) (let ((new-form (expand-source-transform (list* name (cddr form))))) -;; (format t "new form = ~S~%" new-form) (return-from p1-funcall (p1 new-form))) ))))) ;; Otherwise... @@ -1164,9 +1156,6 @@ (let* ((op (car form)) (local-function (find-local-function op))) (when local-function -;; (format t "p1 local call to ~S~%" op) -;; (format t "inline-p = ~S~%" (inline-p op)) - (when (and *enable-inline-expansion* (inline-p op) (local-function-definition local-function)) (let* ((definition (local-function-definition local-function)) @@ -1272,7 +1261,7 @@ (p1 `(%funcall (function ,op) ,@(cdr form))) (p1 maybe-optimized-call)))) (t - form)))))) + (compiler-unsupported "P1 unhandled case ~S" form))))))) (defun install-p1-handler (symbol handler) (setf (get symbol 'p1-handler) handler)) @@ -1322,7 +1311,6 @@ (initialize-p1-handlers) (defun p1-compiland (compiland) -;; (format t "p1-compiland name = ~S~%" (compiland-name compiland)) (let ((*current-compiland* compiland) (*local-functions* *local-functions*) (*visible-variables* *visible-variables*) From ehuelsmann at common-lisp.net Tue Aug 14 10:36:15 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 14 Aug 2012 03:36:15 -0700 Subject: [armedbear-cvs] r14082 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Aug 14 03:36:11 2012 New Revision: 14082 Log: Close #236: fix the COMPILE part of the issue. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue Aug 14 01:01:40 2012 (r14081) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue Aug 14 03:36:11 2012 (r14082) @@ -7341,23 +7341,23 @@ generated class." (aver (eq (car form) 'LAMBDA)) (catch 'compile-defun-abort - (let* ((class-file (make-abcl-class-file :pathname filespec)) - (*compiler-error-bailout* - `(lambda () - (compile-1 - (make-compiland :name ',name - :lambda-expression (make-compiler-error-form ',form) - :class-file - (make-abcl-class-file :pathname ,filespec)) - ,stream))) - (*compile-file-environment* environment)) - (compile-1 (make-compiland :name name - :lambda-expression - (precompiler:precompile-form form t - environment) - :class-file class-file) - stream) - class-file))) + (flet ((compiler-bailout () + (let ((class-file (make-abcl-class-file :pathname filespec)) + (error-form (make-compiler-error-form form))) + (compile-1 (make-compiland :name name + :lambda-expression error-form + :class-file class-file) + stream) + class-file))) + (let* ((class-file (make-abcl-class-file :pathname filespec)) + (*compiler-error-bailout* #'compiler-bailout) + (*compile-file-environment* environment) + (precompiled-form (pre:precompile-form form t environment))) + (compile-1 (make-compiland :name name + :lambda-expression precompiled-form + :class-file class-file) + stream) + class-file)))) (defvar *catch-errors* t) From rschlatte at common-lisp.net Tue Aug 14 11:53:16 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Tue, 14 Aug 2012 04:53:16 -0700 Subject: [armedbear-cvs] r14083 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Tue Aug 14 04:53:16 2012 New Revision: 14083 Log: Comment out some debugging output Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Tue Aug 14 03:36:11 2012 (r14082) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Tue Aug 14 04:53:16 2012 (r14083) @@ -202,9 +202,9 @@ return null; if (! (layout instanceof Layout)) { - (new Error()).printStackTrace(); - LispThread.currentThread().printBacktrace(); - System.out.println("Class: " + this.princToString()); + // (new Error()).printStackTrace(); + // LispThread.currentThread().printBacktrace(); + // System.err.println("Class: " + this.princToString()); return (Layout)Lisp.error(Symbol.TYPE_ERROR, new SimpleString("The value " + layout.princToString() + " is not of expected type " From rschlatte at common-lisp.net Tue Aug 14 12:13:42 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Tue, 14 Aug 2012 05:13:42 -0700 Subject: [armedbear-cvs] r14084 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Tue Aug 14 05:13:42 2012 New Revision: 14084 Log: Robustify printing of partially-initialized generic function objects Modified: trunk/abcl/src/org/armedbear/lisp/print-object.lisp Modified: trunk/abcl/src/org/armedbear/lisp/print-object.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/print-object.lisp Tue Aug 14 04:53:16 2012 (r14083) +++ trunk/abcl/src/org/armedbear/lisp/print-object.lisp Tue Aug 14 05:13:42 2012 (r14084) @@ -59,7 +59,7 @@ (print-unreadable-object (gf stream :identity t) (format stream "~S ~S" (class-name (class-of gf)) - (mop:generic-function-name gf))) + (ignore-errors (mop:generic-function-name gf)))) gf) (defmethod print-object ((method method) stream) From mevenson at common-lisp.net Tue Aug 14 12:16:12 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 14 Aug 2012 05:16:12 -0700 Subject: [armedbear-cvs] r14085 - trunk/abcl/examples/misc Message-ID: Author: mevenson Date: Tue Aug 14 05:16:11 2012 New Revision: 14085 Log: examples/misc: fix installation of Quicklisp from scratch. Modified: trunk/abcl/examples/misc/dotabclrc Modified: trunk/abcl/examples/misc/dotabclrc ============================================================================== --- trunk/abcl/examples/misc/dotabclrc Tue Aug 14 05:13:42 2012 (r14084) +++ trunk/abcl/examples/misc/dotabclrc Tue Aug 14 05:16:11 2012 (r14085) @@ -1,16 +1,18 @@ ;;; -*- Mode: Lisp -*- -;;; Possible codas for inclusion in the Armed Bear startup file #p"~/.abclrc" +;;; Possible code for inclusion in the Armed Bear startup file #p"~/.abclrc" #-quicklisp (let ((quicklisp-local #P"~/quicklisp/setup.lisp") (quicklisp-remote #p"http://beta.quicklisp.org/quicklisp.lisp")) (unless (probe-file quicklisp-local) (when (probe-file quicklisp-remote) ;;; XXX possibly search for a proxy? - (load quicklisp-remote))) + (load quicklisp-remote) + (funcall (intern (symbol-name 'install) :quicklisp-quickstart)))) (when (probe-file quicklisp-local) (load quicklisp-local))) +;; (require :asdf) (require :abcl-contrib) (require :abcl-asdf) From rschlatte at common-lisp.net Tue Aug 14 12:40:57 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Tue, 14 Aug 2012 05:40:57 -0700 Subject: [armedbear-cvs] r14086 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Tue Aug 14 05:40:56 2012 New Revision: 14086 Log: Eliminate numberOfRequiredArgs attribute from standard generic function - calculate it when required instead Modified: trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Modified: trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java Tue Aug 14 05:16:11 2012 (r14085) +++ trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java Tue Aug 14 05:40:56 2012 (r14086) @@ -41,7 +41,6 @@ public class FuncallableStandardObject extends StandardObject { protected LispObject function; - protected int numberOfRequiredArgs; protected FuncallableStandardObject() { Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Tue Aug 14 05:16:11 2012 (r14085) +++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Tue Aug 14 05:40:56 2012 (r14086) @@ -56,7 +56,6 @@ slots[StandardGenericFunctionClass.SLOT_INDEX_LAMBDA_LIST] = NIL; slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS] = NIL; slots[StandardGenericFunctionClass.SLOT_INDEX_OPTIONAL_ARGS] = NIL; - numberOfRequiredArgs = 0; slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS] = NIL; slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS] = NIL; slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS] = @@ -228,7 +227,6 @@ { final StandardGenericFunction gf = checkStandardGenericFunction(first); gf.slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS] = second; - gf.numberOfRequiredArgs = second.length(); return second; } }; @@ -577,8 +575,11 @@ { final StandardGenericFunction gf = checkStandardGenericFunction(first); LispObject args = second; - LispObject[] array = new LispObject[gf.numberOfRequiredArgs]; - for (int i = gf.numberOfRequiredArgs; i-- > 0;) + int numberOfRequiredArgs + = gf.slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS] + .length(); + LispObject[] array = new LispObject[numberOfRequiredArgs]; + for (int i = numberOfRequiredArgs; i-- > 0;) { array[i] = gf.getArgSpecialization(args.car()); args = args.cdr(); @@ -606,8 +607,11 @@ { final StandardGenericFunction gf = checkStandardGenericFunction(first); LispObject args = second; - LispObject[] array = new LispObject[gf.numberOfRequiredArgs]; - for (int i = gf.numberOfRequiredArgs; i-- > 0;) + int numberOfRequiredArgs + = gf.slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS] + .length(); + LispObject[] array = new LispObject[numberOfRequiredArgs]; + for (int i = numberOfRequiredArgs; i-- > 0;) { array[i] = gf.getArgSpecialization(args.car()); args = args.cdr(); From rschlatte at common-lisp.net Tue Aug 14 19:33:05 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Tue, 14 Aug 2012 12:33:05 -0700 Subject: [armedbear-cvs] r14087 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Tue Aug 14 12:33:04 2012 New Revision: 14087 Log: Fix return value of (compile nil fn) - Reported by Vladimir Sedach August 11, 2012 in mail "compile slightly broken for compiled functions" Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue Aug 14 05:40:56 2012 (r14086) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue Aug 14 12:33:04 2012 (r14087) @@ -7479,7 +7479,7 @@ (resolve name) ;; Make sure the symbol has been resolved by the autoloader (setf definition (fdefinition name))) (when (compiled-function-p definition) - (return-from jvm-compile (values name nil nil))) + (return-from jvm-compile (values (or name definition) nil nil))) (let ((catch-errors *catch-errors*) (warnings-p nil) (failure-p nil) From rschlatte at common-lisp.net Tue Aug 14 20:02:17 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Tue, 14 Aug 2012 13:02:17 -0700 Subject: [armedbear-cvs] r14088 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Tue Aug 14 13:02:16 2012 New Revision: 14088 Log: Tell compile, set-function-definition about funcallable objects Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue Aug 14 12:33:04 2012 (r14087) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue Aug 14 13:02:16 2012 (r14088) @@ -7492,7 +7492,7 @@ environment) (unless (and (consp definition) (eq (car definition) 'LAMBDA)) (let ((function definition)) - (when (typep definition 'standard-generic-function) + (when (typep definition 'mop:funcallable-standard-object) (setf function (mop::funcallable-instance-function function))) (multiple-value-setq (expression environment) Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Tue Aug 14 12:33:04 2012 (r14087) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Tue Aug 14 13:02:16 2012 (r14088) @@ -1069,7 +1069,7 @@ (sys::%set-arglist new (sys::arglist old)) (when (macro-function name) (setf new (make-macro name new))) - (if (typep old 'standard-generic-function) + (if (typep old 'mop:funcallable-standard-object) (mop:set-funcallable-instance-function old new) (setf (fdefinition name) new)))) @@ -1180,4 +1180,4 @@ (export '(precompile)) -;;(provide "PRECOMPILER") \ No newline at end of file +;;(provide "PRECOMPILER") From ehuelsmann at common-lisp.net Tue Aug 14 21:06:35 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 14 Aug 2012 14:06:35 -0700 Subject: [armedbear-cvs] r14089 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Aug 14 14:06:34 2012 New Revision: 14089 Log: Close #208: Merge pathname defaults. Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java trunk/abcl/src/org/armedbear/lisp/Lisp.java Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Interpreter.java Tue Aug 14 13:02:16 2012 (r14088) +++ trunk/abcl/src/org/armedbear/lisp/Interpreter.java Tue Aug 14 14:06:34 2012 (r14089) @@ -330,7 +330,8 @@ arg.equals("--load-system-file")) { if (i + 1 < args.length) { if (arg.equals("--load")) - Load.load(new Pathname(args[i + 1]), + Load.load(Pathname.mergePathnames(new Pathname(args[i + 1]), + checkPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.getSymbolValue())), false, false, true); else Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java Tue Aug 14 13:02:16 2012 (r14088) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Tue Aug 14 14:06:34 2012 (r14089) @@ -1649,6 +1649,14 @@ type_error(obj, Symbol.PACKAGE); } + public static Pathname checkPathname(LispObject obj) + { + if (obj instanceof Pathname) + return (Pathname) obj; + return (Pathname) // Not reached. + type_error(obj, Symbol.PATHNAME); + } + public static final Function checkFunction(LispObject obj) { From ehuelsmann at common-lisp.net Tue Aug 14 21:44:44 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 14 Aug 2012 14:44:44 -0700 Subject: [armedbear-cvs] r14090 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Aug 14 14:44:43 2012 New Revision: 14090 Log: Silence a compiler warning when compiling this month's SLIME from Quicklisp: 3 arguments should not warn, since it's allowed; the point being that we're only optimizing the 2-argument case... Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue Aug 14 14:06:34 2012 (r14089) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue Aug 14 14:44:43 2012 (r14090) @@ -2669,7 +2669,7 @@ (t result))))) (defun p2-test-char= (form success-label failure-label) - (when (check-arg-count form 2) + (when (= (length form) 3) ;; only optimize the "exactly 2 arguments" case (let* ((arg1 (%cadr form)) (arg2 (%caddr form))) (with-operand-accumulation From ehuelsmann at common-lisp.net Tue Aug 14 21:53:17 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 14 Aug 2012 14:53:17 -0700 Subject: [armedbear-cvs] r14091 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Aug 14 14:53:16 2012 New Revision: 14091 Log: Make LISTEN work for non-character input streams. Found by Stas Boukarev. Patch by me. Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Stream.java Tue Aug 14 14:44:43 2012 (r14090) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Tue Aug 14 14:53:16 2012 (r14091) @@ -1689,16 +1689,24 @@ if (pastEnd) return NIL; try { - if (! _charReady()) - return NIL; + if (isCharacterInputStream()) { + if (! _charReady()) + return NIL; + + int n = _readChar(); + if (n < 0) + return NIL; - int n = _readChar(); - if (n < 0) - return NIL; - - _unreadChar(n); + _unreadChar(n); - return T; + return T; + } else if (isInputStream()) { + if (! _byteReady()) + return NIL; + + return T; + } else + return error(new StreamError(this, "Not an input stream")); } catch (IOException e) { return error(new StreamError(this, e)); } @@ -1796,6 +1804,12 @@ streamNotCharacterInputStream(); return reader.ready(); } + + protected boolean _byteReady() throws IOException { + if (in == null) + streamNotInputStream(); + return (in.available() != 0); + } /** Writes a character into the underlying stream, * updating charPos while doing so From rschlatte at common-lisp.net Wed Aug 15 07:12:25 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 15 Aug 2012 00:12:25 -0700 Subject: [armedbear-cvs] r14092 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Wed Aug 15 00:12:24 2012 New Revision: 14092 Log: Don't clobber class hierarchy when defining forward-referenced classes - Use initargs when calling change-class for the class metaobject - Robustify make-instances-obsolete against non-finalized classes (e.g. forward-referenced-class) - Report and diagnosis by Stas Boukarev to armedbear-devel on August 11, 2012 ("Forward referenced classes woes") - Fixes ansi tests DEFCLASS.FORWARD-REF.3, DEFCLASS.FORWARD-REF.4 Modified: trunk/abcl/src/org/armedbear/lisp/Layout.java trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Layout.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Layout.java Tue Aug 14 14:53:16 2012 (r14091) +++ trunk/abcl/src/org/armedbear/lisp/Layout.java Wed Aug 15 00:12:24 2012 (r14092) @@ -265,10 +265,20 @@ { final LispObject lispClass = arg; LispObject oldLayout; - if (lispClass instanceof LispClass) - oldLayout = ((LispClass)lispClass).getClassLayout(); - else - oldLayout = Symbol.CLASS_LAYOUT.execute(lispClass); + // Non-finalized classes might not have a valid layout, but they do + // not have instances either so we can abort. + if (lispClass instanceof LispClass) { + if (!((LispClass)lispClass).isFinalized()) + return arg; + oldLayout = ((LispClass)lispClass).getClassLayout(); + } else if (lispClass instanceof StandardObject) { + if (((StandardObject)arg) + .getInstanceSlotValue(StandardClass.symFinalizedP) == NIL) + return arg; + oldLayout = Symbol.CLASS_LAYOUT.execute(lispClass); + } else { + return error(new TypeError(arg, Symbol.CLASS)); + } Layout newLayout = new Layout((Layout)oldLayout); if (lispClass instanceof LispClass) Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Aug 14 14:53:16 2012 (r14091) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Aug 15 00:12:24 2012 (r14092) @@ -3125,7 +3125,7 @@ (setf all-keys (copy-list all-keys)) ; since we modify it (remf all-keys :metaclass) (unless (classp metaclass) (setf metaclass (find-class metaclass))) - (change-class class metaclass) + (apply #'change-class class metaclass all-keys) (apply #'reinitialize-instance class :name name :direct-superclasses (canonicalize-direct-superclasses From ehuelsmann at common-lisp.net Wed Aug 15 20:23:53 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Wed, 15 Aug 2012 13:23:53 -0700 Subject: [armedbear-cvs] r14093 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Aug 15 13:23:51 2012 New Revision: 14093 Log: Fix externalization failure detected by cl-test-grid compilation of LET-PLUS tests. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed Aug 15 00:12:24 2012 (r14092) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed Aug 15 13:23:51 2012 (r14093) @@ -1549,7 +1549,7 @@ (stringp form) (packagep form) (pathnamep form) - (vectorp form) + (arrayp form) (structure-object-p form) (standard-object-p form) (java:java-object-p form)) From ehuelsmann at common-lisp.net Wed Aug 15 21:38:12 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Wed, 15 Aug 2012 14:38:12 -0700 Subject: [armedbear-cvs] r14094 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Aug 15 14:38:12 2012 New Revision: 14094 Log: Factor out the actual compilation when the input stream has been opened in order to allow compilation directly from stream (to be implemented). Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Wed Aug 15 13:23:51 2012 (r14093) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Wed Aug 15 14:38:12 2012 (r14094) @@ -696,86 +696,57 @@ (defvar *forms-for-output* nil) (defvar *fasl-stream* nil) -(defun compile-file (input-file - &key - output-file - ((:verbose *compile-verbose*) *compile-verbose*) - ((:print *compile-print*) *compile-print*) - (extract-toplevel-funcs-and-macros nil) - external-format) - (declare (ignore external-format)) ; FIXME - (unless (or (and (probe-file input-file) (not (file-directory-p input-file))) - (pathname-type input-file)) - (let ((pathname (merge-pathnames (make-pathname :type "lisp") input-file))) - (when (probe-file pathname) - (setf input-file pathname)))) - (setf output-file (make-pathname - :defaults (if output-file - (merge-pathnames output-file - *default-pathname-defaults*) - (compile-file-pathname input-file)) - :version nil)) - (let* ((*output-file-pathname* output-file) - (type (pathname-type output-file)) - (temp-file (merge-pathnames (make-pathname :type (concatenate 'string type "-tmp")) - output-file)) - (temp-file2 (merge-pathnames (make-pathname :type (concatenate 'string type "-tmp2")) - output-file)) - (functions-file (merge-pathnames (make-pathname :type "funcs") output-file)) - (macros-file (merge-pathnames (make-pathname :type "macs") output-file)) - *toplevel-functions* - *toplevel-macros* - (warnings-p nil) - (failure-p nil)) - (with-open-file (in input-file :direction :input) - (let* ((*compile-file-pathname* (make-pathname :defaults (pathname in) - :version nil)) - (*compile-file-truename* (make-pathname :defaults (truename in) - :version nil)) - (*source* *compile-file-truename*) - (*class-number* 0) - (namestring (namestring *compile-file-truename*)) - (start (get-internal-real-time)) - *fasl-uninterned-symbols*) - (when *compile-verbose* - (format t "; Compiling ~A ...~%" namestring)) - (with-compilation-unit () - (with-open-file (out temp-file - :direction :output :if-exists :supersede - :external-format *fasl-external-format*) - (let ((*readtable* *readtable*) - (*read-default-float-format* *read-default-float-format*) - (*read-base* *read-base*) - (*package* *package*) - (jvm::*functions-defined-in-current-file* '()) - (*fbound-names* '()) - (*fasl-stream* out) - *forms-for-output*) - (jvm::with-saved-compiler-policy - (jvm::with-file-compilation - (handler-bind - ((style-warning - #'(lambda (c) - (setf warnings-p t) - ;; let outer handlers do their thing - (signal c) - ;; prevent the next handler - ;; from running: we're a - ;; WARNING subclass - (continue))) - ((or warning compiler-error) - #'(lambda (c) - (declare (ignore c)) - (setf warnings-p t - failure-p t)))) - (loop - (let* ((*source-position* (file-position in)) - (jvm::*source-line-number* (stream-line-number in)) - (form (read in nil in)) - (*compiler-error-context* form)) - (when (eq form in) - (return)) - (process-toplevel-form form out nil)))) +(defun compile-from-stream (in output-file temp-file temp-file2 + extract-toplevel-funcs-and-macros + functions-file macros-file) + (let* ((*compile-file-pathname* (make-pathname :defaults (pathname in) + :version nil)) + (*compile-file-truename* (make-pathname :defaults (truename in) + :version nil)) + (*source* *compile-file-truename*) + (*class-number* 0) + (namestring (namestring *compile-file-truename*)) + (start (get-internal-real-time)) + *fasl-uninterned-symbols*) + (when *compile-verbose* + (format t "; Compiling ~A ...~%" namestring)) + (with-compilation-unit () + (with-open-file (out temp-file + :direction :output :if-exists :supersede + :external-format *fasl-external-format*) + (let ((*readtable* *readtable*) + (*read-default-float-format* *read-default-float-format*) + (*read-base* *read-base*) + (*package* *package*) + (jvm::*functions-defined-in-current-file* '()) + (*fbound-names* '()) + (*fasl-stream* out) + *forms-for-output*) + (jvm::with-saved-compiler-policy + (jvm::with-file-compilation + (handler-bind + ((style-warning + #'(lambda (c) + (setf warnings-p t) + ;; let outer handlers do their thing + (signal c) + ;; prevent the next handler + ;; from running: we're a + ;; WARNING subclass + (continue))) + ((or warning compiler-error) + #'(lambda (c) + (declare (ignore c)) + (setf warnings-p t + failure-p t)))) + (loop + (let* ((*source-position* (file-position in)) + (jvm::*source-line-number* (stream-line-number in)) + (form (read in nil in)) + (*compiler-error-context* form)) + (when (eq form in) + (return)) + (process-toplevel-form form out nil)))) (finalize-fasl-output) (dolist (name *fbound-names*) (fmakunbound name))))))) @@ -859,8 +830,49 @@ (when *compile-verbose* (format t "~&; Wrote ~A (~A seconds)~%" (namestring output-file) - (/ (- (get-internal-real-time) start) 1000.0))))) - (values (truename output-file) warnings-p failure-p))) + (/ (- (get-internal-real-time) start) 1000.0)))) ) + +(defun compile-file (input-file + &key + output-file + ((:verbose *compile-verbose*) *compile-verbose*) + ((:print *compile-print*) *compile-print*) + (extract-toplevel-funcs-and-macros nil) + external-format) + (declare (ignore external-format)) ; FIXME + (flet ((pathname-with-type (pathname type &optional suffix) + (when suffix + (setq type (concatenate 'string type suffix))) + (merge-pathnames (make-pathname :type type) + pathname))) + (unless (or (and (probe-file input-file) + (not (file-directory-p input-file))) + (pathname-type input-file)) + (let ((pathname (pathname-with-type input-file "lisp"))) + (when (probe-file pathname) + (setf input-file pathname)))) + (setf output-file + (make-pathname :defaults + (if output-file + (merge-pathnames output-file + *default-pathname-defaults*) + (compile-file-pathname input-file)) + :version nil)) + (let* ((*output-file-pathname* output-file) + (type (pathname-type output-file)) + (temp-file (pathname-with-type output-file type "-tmp")) + (temp-file2 (pathname-with-type output-file type "-tmp2")) + (functions-file (pathname-with-type output-file "funcs")) + (macros-file (pathname-with-type output-file "macs")) + *toplevel-functions* + *toplevel-macros* + (warnings-p nil) + (failure-p nil)) + (with-open-file (in input-file :direction :input) + (compile-from-stream in output-file temp-file temp-file2 + extract-toplevel-funcs-and-macros + functions-file macros-file)) + (values (truename output-file) warnings-p failure-p)))) (defun compile-file-if-needed (input-file &rest allargs &key force-compile &allow-other-keys) From ehuelsmann at common-lisp.net Wed Aug 15 22:16:20 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Wed, 15 Aug 2012 15:16:20 -0700 Subject: [armedbear-cvs] r14095 - trunk/abcl/test/lisp/abcl Message-ID: Author: ehuelsmann Date: Wed Aug 15 15:16:20 2012 New Revision: 14095 Log: Fix test failures by fixing test incorrectnesses. Modified: trunk/abcl/test/lisp/abcl/class-file.lisp Modified: trunk/abcl/test/lisp/abcl/class-file.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/class-file.lisp Wed Aug 15 14:38:12 2012 (r14094) +++ trunk/abcl/test/lisp/abcl/class-file.lisp Wed Aug 15 15:16:20 2012 (r14095) @@ -232,8 +232,8 @@ (jvm::class-add-method file method) (jvm::with-code-to-method (file method) (jvm::emit 'aload 0) - (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+) - (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+) + (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-symbol+) + (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-symbol+) (jvm::emit-invokespecial-init jvm::+lisp-primitive+ (list jvm::+lisp-object+ jvm::+lisp-object+)) @@ -241,7 +241,7 @@ (let ((method (jvm::make-jvm-method "execute" jvm::+lisp-object+ nil))) (jvm::class-add-method file method) (jvm::with-code-to-method (file method) - (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+) + (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-symbol+) (jvm::emit 'jvm::areturn))) (jvm::finalize-class-file file) (with-open-stream (stream (sys::%make-byte-array-output-stream)) @@ -260,7 +260,7 @@ (let ((method (jvm::make-jvm-method :static-initializer :void nil :flags '(:static)))) (jvm::class-add-method file method) (jvm::with-code-to-method (file method) - (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+) + (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-symbol+) (jvm::emit-putstatic class "N1" jvm::+lisp-object+) (jvm::emit 'return))) (let ((method (jvm::make-jvm-method :constructor :void nil))) @@ -294,8 +294,8 @@ (jvm::class-add-method file method) (jvm::with-code-to-method (file method) (jvm::emit 'aload 0) - (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+) - (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+) + (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-symbol+) + (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-symbol+) (jvm::emit-invokespecial-init jvm::+lisp-primitive+ (list jvm::+lisp-object+ jvm::+lisp-object+)) @@ -303,7 +303,7 @@ (let ((method (jvm::make-jvm-method "execute" jvm::+lisp-object+ nil))) (jvm::class-add-method file method) (jvm::with-code-to-method (file method) - (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+) + (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-symbol+) (jvm::emit 'jvm::areturn))) (let ((method (jvm::make-jvm-method "execute" jvm::+lisp-object+ (list jvm::+lisp-object+)))) @@ -339,7 +339,8 @@ (jvm::allocate-register :int) (push jvm::*register* registers)) (jvm::allocate-register :int) - (push jvm::*register* registers)) + (push jvm::*register* registers) + (jvm::emit 'return)) (jvm::finalize-class-file file) (nreverse registers)) (1 2 3 4 5)) @@ -365,7 +366,8 @@ (jvm::allocate-register :int) (push jvm::*register* registers)) (jvm::allocate-register :int) - (push jvm::*register* registers)) + (push jvm::*register* registers) + (jvm::emit 'return)) (jvm::finalize-class-file file) (nreverse registers)) (1 1 2 2 3)) From ehuelsmann at common-lisp.net Wed Aug 15 22:55:27 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Wed, 15 Aug 2012 15:55:27 -0700 Subject: [armedbear-cvs] r14096 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Aug 15 15:55:27 2012 New Revision: 14096 Log: Don't generate empty static initializers. Note: Given that this commit shrinks our JAR by more than 3k and the fact that these methods only contain 1 byte, we must have had quite a number of them... Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed Aug 15 15:16:20 2012 (r14095) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed Aug 15 15:55:27 2012 (r14096) @@ -1084,7 +1084,9 @@ (with-code-to-method (class (abcl-class-file-constructor class)) (emit 'return)) (with-code-to-method (class (abcl-class-file-static-initializer class)) - (emit 'return)) + (if (= 0 (length *code*)) + (class-remove-method class (abcl-class-file-static-initializer class)) + (emit 'return))) (when *compiler-debug* (print "; Writing class file ") (print (abcl-class-file-class-name class)) Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Wed Aug 15 15:16:20 2012 (r14095) +++ trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Wed Aug 15 15:55:27 2012 (r14096) @@ -763,6 +763,11 @@ (equal (method-descriptor c) return-and-args))) (class-file-methods class)))) +(defun class-remove-method (class method) + (setf (class-file-methods class) + (remove method (class-file-methods class))) + method) + (defun class-add-attribute (class attribute) "Adds `attribute' to the class; attributes must be instances of structure classes which include the `attribute' structure class." From ehuelsmann at common-lisp.net Thu Aug 16 20:01:46 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 16 Aug 2012 13:01:46 -0700 Subject: [armedbear-cvs] r14097 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Aug 16 13:01:43 2012 New Revision: 14097 Log: Indenting. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Wed Aug 15 15:55:27 2012 (r14096) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Thu Aug 16 13:01:43 2012 (r14097) @@ -921,7 +921,7 @@ (dolist (local-function local-functions) (push local-function *local-functions*)) (with-saved-compiler-policy - (process-optimization-declarations (cddr form)) + (process-optimization-declarations (cddr form)) (let* ((block (make-flet-node)) (*block* block) (*blocks* (cons block *blocks*)) From ehuelsmann at common-lisp.net Thu Aug 16 20:09:23 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 16 Aug 2012 13:09:23 -0700 Subject: [armedbear-cvs] r14098 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Aug 16 13:09:23 2012 New Revision: 14098 Log: Reorganize binding *CURRENT-COMPILAND*, WITH-SAVED-COMPILER-POLICY. Add missing WITH-SAVED-COMPILER-POLICY and PROCESS-OPTIMIZATION-DECLARATIONS. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu Aug 16 13:01:43 2012 (r14097) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu Aug 16 13:09:23 2012 (r14098) @@ -3251,8 +3251,10 @@ (dolist (variable (m-v-b-free-specials block)) (push variable *visible-variables*)) ;; Body. - (let ((*blocks* (cons block *blocks*))) - (compile-progn-body (cdddr form) target)) + (with-saved-compiler-policy + (process-optimization-declarations (cdddr form)) + (let ((*blocks* (cons block *blocks*))) + (compile-progn-body (cdddr form) target))) (when bind-special-p (restore-dynamic-environment (m-v-b-environment-register block))))) @@ -4102,10 +4104,8 @@ :element-type '(unsigned-byte 8) :if-exists :supersede))) (with-class-file class-file - (let ((*current-compiland* compiland)) - (with-saved-compiler-policy - (compile-to-jvm-class compiland) - (finish-class (compiland-class-file compiland) f))))) + (compile-to-jvm-class compiland) + (finish-class (compiland-class-file compiland) f))) (when stream (let ((bytes (sys::%get-output-stream-bytes stream))) (sys::put-memory-function *memory-class-loader* @@ -4127,8 +4127,10 @@ (push local-function *local-functions*)) (dolist (special (flet-free-specials block)) (push special *visible-variables*)) - (let ((*blocks* (cons block *blocks*))) - (compile-progn-body body target representation)))) + (with-saved-compiler-policy + (process-optimization-declarations body) + (let ((*blocks* (cons block *blocks*))) + (compile-progn-body body target representation))))) (defknown p2-labels-node (t t t) t) (defun p2-labels-node (block target representation) @@ -4143,8 +4145,10 @@ (compile-local-function local-function)) (dolist (special (labels-free-specials block)) (push special *visible-variables*)) - (let ((*blocks* (cons block *blocks*))) - (compile-progn-body body target representation)))) + (with-saved-compiler-policy + (process-optimization-declarations body) + (let ((*blocks* (cons block *blocks*))) + (compile-progn-body body target representation))))) (defun p2-lambda (local-function target) (compile-local-function local-function) @@ -7055,7 +7059,8 @@ (*visible-variables* *visible-variables*) (*thread* nil) - (*initialize-thread-var* nil)) + (*initialize-thread-var* nil) + (*current-compiland* compiland)) (with-code-to-method (class-file method) (setf *register* 1 ;; register 0: "this" pointer @@ -7171,38 +7176,41 @@ (setf (variable-register variable) register) (setf (variable-index variable) nil))))) - (p2-compiland-process-type-declarations body) - (generate-type-checks-for-variables (compiland-arg-vars compiland)) + (with-saved-compiler-policy + (process-optimization-declarations body) + + (p2-compiland-process-type-declarations body) + (generate-type-checks-for-variables (compiland-arg-vars compiland)) ;; Unbox variables. - (dolist (variable (compiland-arg-vars compiland)) - (p2-compiland-unbox-variable variable)) + (dolist (variable (compiland-arg-vars compiland)) + (p2-compiland-unbox-variable variable)) ;; Establish dynamic bindings for any variables declared special. - (when (some #'variable-special-p (compiland-arg-vars compiland)) - ;; Save the dynamic environment - (setf (compiland-environment-register compiland) - (allocate-register nil)) - (save-dynamic-environment (compiland-environment-register compiland)) - (dolist (variable (compiland-arg-vars compiland)) - (when (variable-special-p variable) - (setf (variable-binding-register variable) (allocate-register nil)) - (emit-push-current-thread) - (emit-push-variable-name variable) - (cond ((variable-register variable) - (aload (variable-register variable)) - (setf (variable-register variable) nil)) - ((variable-index variable) - (aload (compiland-argument-register compiland)) - (emit-push-constant-int (variable-index variable)) - (emit 'aaload) - (setf (variable-index variable) nil))) - (emit-invokevirtual +lisp-thread+ "bindSpecial" - (list +lisp-symbol+ +lisp-object+) - +lisp-special-binding+) - (astore (variable-binding-register variable))))) + (when (some #'variable-special-p (compiland-arg-vars compiland)) + ;; Save the dynamic environment + (setf (compiland-environment-register compiland) + (allocate-register nil)) + (save-dynamic-environment (compiland-environment-register compiland)) + (dolist (variable (compiland-arg-vars compiland)) + (when (variable-special-p variable) + (setf (variable-binding-register variable) (allocate-register nil)) + (emit-push-current-thread) + (emit-push-variable-name variable) + (cond ((variable-register variable) + (aload (variable-register variable)) + (setf (variable-register variable) nil)) + ((variable-index variable) + (aload (compiland-argument-register compiland)) + (emit-push-constant-int (variable-index variable)) + (emit 'aaload) + (setf (variable-index variable) nil))) + (emit-invokevirtual +lisp-thread+ "bindSpecial" + (list +lisp-symbol+ +lisp-object+) + +lisp-special-binding+) + (astore (variable-binding-register variable))))) - (compile-progn-body body 'stack) + (compile-progn-body body 'stack)) (when (compiland-environment-register compiland) (restore-dynamic-environment (compiland-environment-register compiland))) @@ -7292,12 +7300,9 @@ (let ((*all-variables* nil) (*closure-variables* nil) (*undefined-variables* nil) - (*local-functions* *local-functions*) - (*current-compiland* compiland)) - (with-saved-compiler-policy - ;; Pass 1. - (p1-compiland compiland)) + (*local-functions* *local-functions*)) + (p1-compiland compiland) ;; *all-variables* doesn't contain variables which ;; are in an enclosing lexical environment (variable-environment) ;; so we don't need to filter them out @@ -7323,10 +7328,8 @@ ;; Pass 2. (with-class-file (compiland-class-file compiland) - (with-saved-compiler-policy - (compile-to-jvm-class compiland) - ;; (finalize-class-file (compiland-class-file compiland)) - (finish-class (compiland-class-file compiland) stream))))) + (compile-to-jvm-class compiland) + (finish-class (compiland-class-file compiland) stream)))) (defvar *compiler-error-bailout*) From ehuelsmann at common-lisp.net Fri Aug 17 05:54:20 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 16 Aug 2012 22:54:20 -0700 Subject: [armedbear-cvs] r14099 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Aug 16 22:54:19 2012 New Revision: 14099 Log: Make the autoloader smarter: make sure exported symbols are exported again in the autoloader. Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Thu Aug 16 13:09:23 2012 (r14098) +++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Thu Aug 16 22:54:19 2012 (r14099) @@ -193,15 +193,33 @@ (write '(identity T) :stream f) (dolist (package '(:format :sequence :loop :mop :xp :precompiler :profiler :java :jvm :extensions :threads - :toplevel :system :cl)) + :top-level :system :cl)) ;; Limit the set of packages: ;; During incremental compilation, the packages GRAY-STREAMS ;; and ASDF are not being created. Nor are these packages ;; vital to the correct operation of the base system. + + (let ((*package* (find-package package)) + externals) + (do-external-symbols (sym package + externals) + (when (eq (symbol-package sym) + *package*) + (push sym externals))) + (when externals + (write-line ";; EXPORTS" f) + (write `(cl:in-package ,package) :stream f) + (terpri f) + (write `(cl:export ',externals) :stream f) + (terpri f))) + + + (terpri f) (write-line ";; FUNCTIONS" f) (terpri f) (write-package-filesets f package 'ext:autoload (combos-to-fileset-symbols funcs)) + (terpri f) (write-line ";; MACROS" f) (terpri f) (write-package-filesets f package 'ext:autoload-macro From ehuelsmann at common-lisp.net Fri Aug 17 05:56:32 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 16 Aug 2012 22:56:32 -0700 Subject: [armedbear-cvs] r14100 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Aug 16 22:56:31 2012 New Revision: 14100 Log: Re #226: Clean symbols from manually maintained autoloads.lisp which are also automatically detected by the automatic autoloader. Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Thu Aug 16 22:54:19 2012 (r14099) +++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Thu Aug 16 22:56:31 2012 (r14100) @@ -48,259 +48,64 @@ (in-package "SYSTEM") -(autoload '(char/= char> char>= char-not-equal) - "chars") -(autoload '(string-upcase string-downcase string-capitalize - nstring-upcase nstring-downcase nstring-capitalize - string= string/= string-equal string-not-equal - string< string> - string<= string>= - string-lessp string-greaterp - string-not-lessp string-not-greaterp - string-left-trim string-right-trim string-trim) - "strings") -(autoload 'copy-symbol) -(autoload '(open parse-integer)) -(autoload '(sort stable-sort merge) "sort") -(autoload 'tree-equal) -(autoload 'make-hash-table) -(autoload 'list-length) -(autoload 'revappend) -(autoload '(butlast nbutlast) "butlast") -(autoload 'ldiff) -(autoload '(subst subst-if subst-if-not nsubst nsubst-if nsubst-if-not) - "subst") -(autoload '(sublis nsublis) "sublis") -(autoload '(member-if member-if-not) "member-if") -(autoload 'tailp) -(autoload 'adjoin) -(autoload '(union nunion - intersection nintersection - set-difference nset-difference - set-exclusive-or nset-exclusive-or - subsetp) - "sets") -(autoload '(assoc assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not - acons pairlis copy-alist) - "assoc") -(autoload-macro 'sequence::seq-dispatch "extensible-sequences-base") -(autoload '(mapcan mapl maplist mapcon) "map1") -(autoload 'make-sequence) -;(autoload 'sequence::fill "extensible-sequences") -(autoload '(copy-seq fill replace)) -(autoload '(map map-into)) -(autoload 'reduce) -(autoload '(delete delete-if delete-if-not) "delete") -(autoload '(remove remove-if remove-if-not) "remove") -(autoload '(remove-duplicates delete-duplicates)) -(autoload '(substitute substitute-if substitute-if-not) "substitute") -(autoload '(nsubstitute nsubstitute-if nsubstitute-if-not) "nsubstitute") -(autoload '(position position-if position-if-not find find-if find-if-not - list-find* vector-find*) - "find") -(autoload '(count count-if count-if-not) "count") -(autoload '(mismatch search)) -(autoload 'make-string) -(autoload 'directory "directory") -(autoload '(signum round ffloor fceiling fround rationalize gcd isqrt - float-precision decode-float conjugate phase) - "numbers") -(autoload 'boole) (export '%ldb '#:system) -(autoload '(byte byte-size byte-position %ldb ldb ldb-test dpb) "ldb") -(autoload 'lcm) -(autoload '(apropos apropos-list) "apropos") -(autoload '(y-or-n-p yes-or-no-p) "query") -(autoload '(decode-universal-time get-decoded-time encode-universal-time) - "time") -(autoload 'gentemp) -(autoload '(bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 - bit-andc2 bit-orc1 bit-orc2 bit-not) - "bit-array-ops") -(autoload 'deposit-field) -(autoload 'mask-field) -(autoload '(ensure-class ensure-generic-function make-condition - mop::ensure-method - define-method-combination - %defgeneric - canonicalize-direct-superclasses - slot-value slot-makunbound slot-boundp) - "clos") (export '(ensure-class subclassp %defgeneric canonicalize-direct-superclasses) '#:system) -(autoload '(inspect istep) "inspect") -(autoload 'enough-namestring) -(autoload 'upgraded-complex-part-type) - -(autoload '(tpl::top-level-loop) "top-level") - -(autoload 'hash-table-iterator-function "with-hash-table-iterator") -(autoload-macro 'with-hash-table-iterator) - -(autoload 'package-iterator-function "with-package-iterator") -(autoload-macro 'with-package-iterator) - -(autoload-macro 'remf) -(autoload-macro 'check-type) -(autoload-macro 'deftype) -(autoload 'expand-deftype "deftype") -(autoload-macro '(defclass defgeneric defmethod define-condition) "clos") -(autoload-macro 'with-standard-io-syntax) -(autoload 'sys::%with-standard-io-syntax "with-standard-io-syntax") -(autoload-macro 'psetf) -(autoload-macro 'rotatef) -(autoload-macro 'shiftf) - -(autoload-macro 'do-all-symbols) -(autoload-macro '(trace untrace) "trace") -(autoload '(sys::list-traced-functions sys::trace-1 sys::untrace-1 sys::untrace-all) "trace") -(autoload 'sys::%define-symbol-macro "define-symbol-macro") -(autoload-macro 'define-symbol-macro) -(autoload-macro 'with-slots) -(autoload-macro 'with-accessors) -(autoload-macro '(sys::%print-unreadable-object print-unreadable-object) - "print-unreadable-object") -(autoload 'print-object) -(autoload-macro '(prog prog*) "prog") (export 'concatenate-to-string '#:system) -(autoload '(concatenate-to-string concatenate) "concatenate") -(autoload 'parse-lambda-list) -(autoload-macro 'assert) -(autoload '(sys::assert-error sys::assert-prompt) "assert") -(autoload-macro 'with-input-from-string) -(autoload-macro 'with-output-to-string) -(autoload 'ensure-directories-exist) -(autoload 'coerce) -(autoload 'read-from-string) -(autoload 'read-sequence) -(autoload 'write-sequence) -(autoload 'make-load-form-saving-slots) -(autoload 'compile-file) -(autoload 'compile-file-pathname) - -(autoload 'format "format") -(autoload-macro 'formatter "format") - -(autoload '(write-byte read-byte) "byte-io") -(autoload-macro 'with-open-file) -(autoload '(pathname-host pathname-device pathname-directory pathname-name - pathname-type wild-pathname-p pathname-match-p translate-pathname - logical-pathname-translations translate-logical-pathname - load-logical-pathname-translations logical-pathname - parse-namestring) - "pathnames") -(autoload 'make-string-output-stream) -(autoload 'find-all-symbols) -(autoload 'dribble) -(autoload-macro 'step) -(autoload 'load) -(autoload '(compile with-file-compilation) "jvm") -(autoload-macro 'with-compilation-unit "jvm") - -(autoload-macro '(case ccase ecase typecase ctypecase etypecase) "case") -(autoload-macro '(and cond dolist dotimes - do-symbols do-external-symbols - multiple-value-bind multiple-value-list multiple-value-setq - nth-value - or)) -(autoload-macro '(do do*) "do") - -(autoload 'ed) -(autoload 'describe) -(autoload 'disassemble) (in-package "MOP") (export '(class-precedence-list class-slots slot-definition-allocation - slot-definition-initargs slot-definition-initform - slot-definition-initfunction slot-definition-name - compute-applicable-methods - compute-applicable-methods-using-classes)) -(autoload '(class-precedence-list class-slots) "clos") + slot-definition-initargs slot-definition-initform + slot-definition-initfunction slot-definition-name + compute-applicable-methods + compute-applicable-methods-using-classes)) ;; Java interface. (in-package "JAVA") (export 'jregister-handler "JAVA") -(autoload 'jregister-handler "java") (export 'jinterface-implementation "JAVA") -(autoload 'jinterface-implementation "java") (export 'jmake-invocation-handler "JAVA") -(autoload 'jmake-invocation-handler "java") (export 'jmake-proxy "JAVA") -(autoload 'jmake-proxy "java") (export 'jproperty-value "JAVA") -(autoload 'jproperty-value "java") (export 'jobject-class "JAVA") -(autoload 'jobject-class "java") (export 'jclass-superclass "JAVA") -(autoload 'jclass-superclass "java") (export 'jclass-interfaces "JAVA") -(autoload 'jclass-interfaces "java") (export 'jclass-interface-p "JAVA") -(autoload 'jclass-interface-p "java") (export 'jclass-superclass-p "JAVA") -(autoload 'jclass-superclass-p "java") (export 'jclass-array-p "JAVA") -(autoload 'jclass-array-p "java") (export 'jarray-component-type "JAVA") -(autoload 'jarray-component-type "java") (export 'jarray-length "JAVA") -(autoload 'jarray-length "java") (export 'jnew-array-from-array "JAVA") -(autoload 'jnew-array-from-array "java") (export 'jnew-array-from-list "JAVA") -(autoload 'jnew-array-from-list "java") (export 'jarray-from-list "JAVA") -(autoload 'jarray-from-list "java") (export 'jclass-constructors "JAVA") -(autoload 'jclass-constructors "java") (export 'jconstructor-params "JAVA") -(autoload 'jconstructor-params "java") (export 'jclass-field "JAVA") -(autoload 'jclass-field "java") (export 'jclass-fields "JAVA") -(autoload 'jclass-fields "java") (export 'jfield-type "JAVA") -(autoload 'jfield-type "java") (export 'jfield-name "JAVA") -(autoload 'jfield-name "java") (export 'jclass-methods "JAVA") -(autoload 'jclass-methods "java") (export 'jmethod-params "JAVA") -(autoload 'jmethod-params "java") (export 'jmethod-name "JAVA") -(autoload 'jmethod-name "java") (export 'jinstance-of-p "JAVA") -(autoload 'jinstance-of-p "java") (export 'jmember-static-p "JAVA") -(autoload 'jmember-static-p "java") (export 'jmember-public-p "JAVA") -(autoload 'jmember-public-p "java") (export 'jmember-protected-p "JAVA") -(autoload 'jmember-protected-p "java") (export 'jnew-runtime-class "JAVA") -(autoload 'jnew-runtime-class "runtime-class") (export 'define-java-class "JAVA") -(autoload-macro 'define-java-class "runtime-class") (export 'ensure-java-class "JAVA") -(autoload 'ensure-java-class "java") (export 'chain "JAVA") -(autoload-macro 'chain "java") (export 'jmethod-let "JAVA") -(autoload-macro 'jmethod-let "java") (export 'jequal "JAVA") -(autoload 'jequal "java") ;; Profiler. (in-package "PROFILER") (export '(*granularity* show-call-counts show-hot-counts with-profiling)) -(autoload '(show-call-counts show-hot-counts) "profiler") -(autoload-macro 'with-profiling "profiler") ;; Extensions. (in-package "EXTENSIONS") (export 'simple-search) -(autoload 'simple-search "search") (export 'run-shell-command) (autoload 'run-shell-command) (export 'run-program) @@ -324,49 +129,18 @@ (autoload 'process-kill "run-program") (export 'make-socket) -(autoload 'make-socket "socket") (export 'make-server-socket) -(autoload 'make-server-socket "socket") (export 'server-socket-close) -(autoload 'server-socket-close "socket") (export 'socket-accept) -(autoload 'socket-accept "socket") (export 'socket-close) -(autoload 'socket-close "socket") (export 'get-socket-stream) -(autoload 'get-socket-stream "socket") (export 'socket-peer-port) -(autoload 'socket-peer-port "socket") (export 'socket-local-port) -(autoload 'socket-local-port "socket") (export 'socket-local-address) -(autoload 'socket-local-address "socket") (export 'socket-peer-address) -(autoload 'socket-peer-address "socket") (in-package "THREADS") -(autoload '(;; MAKE-THREAD helper - thread-function-wrapper - - ;; Mailbox - make-mailbox mailbox-send mailbox-empty-p - mailbox-read mailbox-peek - - ;; Lock - make-thread-lock - - ;; Mutex - make-mutex get-mutex release-mutex) - "threads") - -(autoload-macro '(;; Lock - with-thread-lock - - ;; Mutex - with-mutex) - "threads") - (export '(make-mailbox mailbox-send mailbox-empty-p mailbox-read mailbox-peek)) (export '(make-thread-lock with-thread-lock)) @@ -376,33 +150,22 @@ (in-package "EXTENSIONS") (export '(grovel-java-definitions compile-system)) -(autoload '(grovel-java-definitions compile-system) "compile-system") (export 'aver) -(autoload-macro 'aver) -(autoload 'sys::%failed-aver "aver") (export 'collect) -(autoload-macro 'collect) (export 'compile-file-if-needed) -(autoload 'compile-file-if-needed "compile-file") (export 'describe-compiler-policy) -(autoload 'describe-compiler-policy) (export 'macroexpand-all) -(autoload 'macroexpand-all "format") (export '*gui-backend*) (export 'init-gui) -(autoload 'init-gui "gui") (export 'make-dialog-prompt-stream) -(autoload 'make-dialog-prompt-stream "gui") ;; JVM compiler. (in-package "JVM") (export '(jvm-compile-package)) -(autoload '%with-compilation-unit "jvm") (in-package "LISP") (export 'compiler-let) -(autoload 'compiler-let) (in-package "SYSTEM") @@ -413,48 +176,17 @@ (export '(process-optimization-declarations inline-p notinline-p inline-expansion expand-inline note-name-defined precompile)) -(autoload '(process-optimization-declarations - inline-p notinline-p inline-expansion expand-inline - note-name-defined precompile) "precompiler") ;; #:SYSTEM in SOURCE-TRANSFORM.LISP (export '(source-transform define-source-transform expand-source-transform)) -(autoload '(source-transform define-source-transform set-source-transform - expand-source-transform) - "source-transform") (in-package "PRECOMPILER") (export '(precompile-form precompile)) -(autoload '(precompile-form) "precompiler") - - -;; items in the XP package (pprint.lisp) - -(in-package "XP") - -(sys::autoload '(xp-structure-p write-string++ output-pretty-object - pprint-logical-block+ maybe-initiate-xp-printing - check-block-abbreviation start-block end-block - pprint-pop-check+) "pprint") - -(sys::autoload-macro '(pprint-logical-block+ pprint-pop+) "pprint") - -(in-package "COMMON-LISP") - -(sys::autoload '(documentation) "clos") - -(sys::autoload '(write print prin1 princ pprint write-to-string - prin1-to-string princ-to-string write-char - write-string write-line terpri finish-output - fresh-line force-output clear-output - pprint-newline pprint-indent pprint-tab pprint-linear - pprint-fill pprint-tabular) "pprint") -(sys::autoload-macro '(pprint-logical-block) "pprint") (in-package "SYSTEM") From ehuelsmann at common-lisp.net Fri Aug 17 06:26:50 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 16 Aug 2012 23:26:50 -0700 Subject: [armedbear-cvs] r14101 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Aug 16 23:26:49 2012 New Revision: 14101 Log: Fix some compilation warnings and errors. Modified: trunk/abcl/src/org/armedbear/lisp/top-level.lisp Modified: trunk/abcl/src/org/armedbear/lisp/top-level.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/top-level.lisp Thu Aug 16 22:56:31 2012 (r14100) +++ trunk/abcl/src/org/armedbear/lisp/top-level.lisp Thu Aug 16 23:26:49 2012 (r14101) @@ -41,7 +41,6 @@ (in-package #:top-level) -(import '(sys::%format sys::list-traced-functions sys::trace-1 sys::untrace-1 sys::untrace-all)) (defvar *null-cmd* (gensym)) (defvar *handled-cmd* (gensym)) @@ -61,10 +60,10 @@ (defun repl-prompt-fun (stream) (fresh-line stream) (when (> *debug-level* 0) - (%format stream "[~D~A] " + (sys::%format stream "[~D~A] " *debug-level* (if sys::*inspect-break* "i" ""))) - (%format stream "~A(~D): " (prompt-package-name) *cmd-number*)) + (sys::%format stream "~A(~D): " (prompt-package-name) *cmd-number*)) (defparameter *repl-prompt-fun* #'repl-prompt-fun) @@ -94,13 +93,13 @@ (defun error-command (ignored) (declare (ignore ignored)) (when *debug-condition* - (let* ((s (%format nil "~A" *debug-condition*)) + (let* ((s (sys::%format nil "~A" *debug-condition*)) (len (length s))) (when (plusp len) (setf (schar s 0) (char-upcase (schar s 0))) (unless (eql (schar s (1- len)) #\.) (setf s (concatenate 'string s ".")))) - (%format *debug-io* "~A~%" s)) + (sys::%format *debug-io* "~A~%" s)) (show-restarts (compute-restarts) *debug-io*))) (defun print-frame (frame stream &key prefix) @@ -172,7 +171,7 @@ (defun package-command (args) (cond ((null args) - (%format *standard-output* "The ~A package is current.~%" + (sys::%format *standard-output* "The ~A package is current.~%" (package-name *package*))) ((and *old-package* (string= args "-") (null (find-package "-"))) (rotatef *old-package* *package*)) @@ -184,7 +183,7 @@ (if pkg (setf *old-package* *package* *package* pkg) - (%format *standard-output* "Unknown package ~A.~%" args)))))) + (sys::%format *standard-output* "Unknown package ~A.~%" args)))))) (defun reset-command (ignored) (declare (ignore ignored)) @@ -205,7 +204,7 @@ (if *old-pwd* (setf args (namestring *old-pwd*)) (progn - (%format t "No previous directory.") + (sys::%format t "No previous directory.") (return-from cd-command)))) ((and (> (length args) 1) (string= (subseq args 0 2) "~/") (setf args (concatenate 'string @@ -217,8 +216,8 @@ (unless (equal dir *default-pathname-defaults*) (setf *old-pwd* *default-pathname-defaults* *default-pathname-defaults* dir)) - (%format t "~A" (namestring *default-pathname-defaults*))) - (%format t "Error: no such directory (~S).~%" args)))) + (sys::%format t "~A" (namestring *default-pathname-defaults*))) + (sys::%format t "Error: no such directory (~S).~%" args)))) (defun ls-command (args) (let ((args (if (stringp args) args "")) @@ -265,19 +264,19 @@ (defun pwd-command (ignored) (declare (ignore ignored)) - (%format t "~A~%" (namestring *default-pathname-defaults*))) + (sys::%format t "~A~%" (namestring *default-pathname-defaults*))) (defun trace-command (args) (if (null args) - (%format t "~A~%" (list-traced-functions)) + (sys::%format t "~A~%" (sys::list-traced-functions)) (dolist (f (tokenize args)) - (trace-1 (read-from-string f))))) + (sys::trace-1 (read-from-string f))))) (defun untrace-command (args) (if (null args) - (untrace-all) + (sys::untrace-all) (dolist (f (tokenize args)) - (untrace-1 (read-from-string f))))) + (sys::untrace-1 (read-from-string f))))) (defconstant spaces (make-string 32 :initial-element #\space)) @@ -286,28 +285,6 @@ (concatenate 'string string (subseq spaces 0 (- width (length string)))) string)) -(defun %help-command (prefix) - (let ((prefix-len (length prefix))) - (when (and (> prefix-len 0) - (eql (schar prefix 0) *command-char*)) - (setf prefix (subseq prefix 1)) - (decf prefix-len)) - (%format t "~% COMMAND ABBR DESCRIPTION~%") - (dolist (entry *command-table*) - (when (or (null prefix) - (and (<= prefix-len (length (entry-name entry))) - (string-equal prefix (subseq (entry-name entry) 0 prefix-len)))) - (%format t " ~A~A~A~%" - (pad (entry-name entry) 12) - (pad (entry-abbreviation entry) 5) - (entry-help entry)))) - (%format t "~%Commands must be prefixed by the command character, which is '~A'~A.~%~%" - *command-char* (if (eql *command-char* #\:) " by default" "")))) - -(defun help-command (&optional ignored) - (declare (ignore ignored)) - (%help-command nil)) - (defparameter *command-table* '(("apropos" "ap" apropos-command "apropos") ("bt" nil backtrace-command "backtrace n stack frames (default 8)") @@ -332,6 +309,28 @@ ("trace" "tr" trace-command "trace function(s)") ("untrace" "untr" untrace-command "untrace function(s)"))) +(defun %help-command (prefix) + (let ((prefix-len (length prefix))) + (when (and (> prefix-len 0) + (eql (schar prefix 0) *command-char*)) + (setf prefix (subseq prefix 1)) + (decf prefix-len)) + (sys::%format t "~% COMMAND ABBR DESCRIPTION~%") + (dolist (entry *command-table*) + (when (or (null prefix) + (and (<= prefix-len (length (entry-name entry))) + (string-equal prefix (subseq (entry-name entry) 0 prefix-len)))) + (sys::%format t " ~A~A~A~%" + (pad (entry-name entry) 12) + (pad (entry-abbreviation entry) 5) + (entry-help entry)))) + (sys::%format t "~%Commands must be prefixed by the command character, which is '~A'~A.~%~%" + *command-char* (if (eql *command-char* #\:) " by default" "")))) + +(defun help-command (&optional ignored) + (declare (ignore ignored)) + (%help-command nil)) + (defun entry-name (entry) (first entry)) @@ -367,8 +366,8 @@ (args (if pos (subseq form (1+ pos)) nil))) (let ((command (find-command command-string))) (cond ((null command) - (%format t "Unknown top-level command \"~A\".~%" command-string) - (%format t "Type \"~Ahelp\" for a list of available commands." *command-char*)) + (sys::%format t "Unknown top-level command \"~A\".~%" command-string) + (sys::%format t "Type \"~Ahelp\" for a list of available commands." *command-char*)) (t (when args (setf args (string-trim (list #\space #\return) args)) @@ -424,7 +423,7 @@ (defun top-level-loop () (fresh-line) (unless sys:*noinform* - (%format t "Type \"~Ahelp\" for a list of available commands.~%" *command-char*)) + (sys::%format t "Type \"~Ahelp\" for a list of available commands.~%" *command-char*)) (loop (setf *inspected-object* nil *inspected-object-stack* nil From ehuelsmann at common-lisp.net Fri Aug 17 06:27:28 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 16 Aug 2012 23:27:28 -0700 Subject: [armedbear-cvs] r14102 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Aug 16 23:27:28 2012 New Revision: 14102 Log: Move some EXPORTs from autoloads.lisp to mop.lisp. Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp trunk/abcl/src/org/armedbear/lisp/mop.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Thu Aug 16 23:26:49 2012 (r14101) +++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Thu Aug 16 23:27:28 2012 (r14102) @@ -49,16 +49,11 @@ (in-package "SYSTEM") (export '%ldb '#:system) -(export '(ensure-class subclassp %defgeneric canonicalize-direct-superclasses) - '#:system) (export 'concatenate-to-string '#:system) (in-package "MOP") -(export '(class-precedence-list class-slots slot-definition-allocation - slot-definition-initargs slot-definition-initform - slot-definition-initfunction slot-definition-name - compute-applicable-methods - compute-applicable-methods-using-classes)) +(export '(class-precedence-list class-slots %defgeneric + canonicalize-direct-superclasses)) ;; Java interface. Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/mop.lisp Thu Aug 16 23:26:49 2012 (r14101) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Thu Aug 16 23:27:28 2012 (r14102) @@ -51,7 +51,7 @@ standard-accessor-method standard-reader-method standard-writer-method - + compute-effective-slot-definition compute-class-precedence-list compute-default-initargs @@ -105,6 +105,7 @@ direct-slot-definition-class effective-slot-definition-class + slot-definition-allocation slot-definition-initargs slot-definition-location slot-definition-name From ehuelsmann at common-lisp.net Fri Aug 17 06:30:13 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 16 Aug 2012 23:30:13 -0700 Subject: [armedbear-cvs] r14103 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Aug 16 23:30:13 2012 New Revision: 14103 Log: Follow-up to r14102. Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp trunk/abcl/src/org/armedbear/lisp/mop.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Thu Aug 16 23:27:28 2012 (r14102) +++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Thu Aug 16 23:30:13 2012 (r14103) @@ -52,7 +52,7 @@ (export 'concatenate-to-string '#:system) (in-package "MOP") -(export '(class-precedence-list class-slots %defgeneric +(export '(%defgeneric canonicalize-direct-superclasses)) Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/mop.lisp Thu Aug 16 23:27:28 2012 (r14102) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Thu Aug 16 23:30:13 2012 (r14103) @@ -107,6 +107,8 @@ effective-slot-definition-class slot-definition-allocation slot-definition-initargs + slot-definition-initform + slot-definition-initfunction slot-definition-location slot-definition-name slot-definition-readers From ehuelsmann at common-lisp.net Fri Aug 17 08:48:53 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 17 Aug 2012 01:48:53 -0700 Subject: [armedbear-cvs] r14104 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 17 01:48:50 2012 New Revision: 14104 Log: Move exports from the JAVA package to java.lisp. Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp trunk/abcl/src/org/armedbear/lisp/java.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Thu Aug 16 23:30:13 2012 (r14103) +++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Fri Aug 17 01:48:50 2012 (r14104) @@ -55,45 +55,6 @@ (export '(%defgeneric canonicalize-direct-superclasses)) - -;; Java interface. -(in-package "JAVA") -(export 'jregister-handler "JAVA") -(export 'jinterface-implementation "JAVA") -(export 'jmake-invocation-handler "JAVA") -(export 'jmake-proxy "JAVA") -(export 'jproperty-value "JAVA") -(export 'jobject-class "JAVA") -(export 'jclass-superclass "JAVA") -(export 'jclass-interfaces "JAVA") -(export 'jclass-interface-p "JAVA") -(export 'jclass-superclass-p "JAVA") -(export 'jclass-array-p "JAVA") -(export 'jarray-component-type "JAVA") -(export 'jarray-length "JAVA") -(export 'jnew-array-from-array "JAVA") -(export 'jnew-array-from-list "JAVA") -(export 'jarray-from-list "JAVA") -(export 'jclass-constructors "JAVA") -(export 'jconstructor-params "JAVA") -(export 'jclass-field "JAVA") -(export 'jclass-fields "JAVA") -(export 'jfield-type "JAVA") -(export 'jfield-name "JAVA") -(export 'jclass-methods "JAVA") -(export 'jmethod-params "JAVA") -(export 'jmethod-name "JAVA") -(export 'jinstance-of-p "JAVA") -(export 'jmember-static-p "JAVA") -(export 'jmember-public-p "JAVA") -(export 'jmember-protected-p "JAVA") -(export 'jnew-runtime-class "JAVA") -(export 'define-java-class "JAVA") -(export 'ensure-java-class "JAVA") -(export 'chain "JAVA") -(export 'jmethod-let "JAVA") -(export 'jequal "JAVA") - ;; Profiler. (in-package "PROFILER") (export '(*granularity* show-call-counts show-hot-counts with-profiling)) Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/java.lisp Thu Aug 16 23:30:13 2012 (r14103) +++ trunk/abcl/src/org/armedbear/lisp/java.lisp Fri Aug 17 01:48:50 2012 (r14104) @@ -36,6 +36,22 @@ (defvar *classloader* (get-default-classloader)) + + +(EXPORT '(JREGISTER-HANDLER JINTERFACE-IMPLEMENTATION JMAKE-INVOCATION-HANDLER + JMAKE-PROXY JPROPERTY-VALUE JOBJECT-CLASS JCLASS-SUPERCLASS + JCLASS-INTERFACES JCLASS-INTERFACE-P JCLASS-SUPERCLASS-P + JCLASS-ARRAY-P JARRAY-COMPONENT-TYPE JARRAY-LENGTH + JNEW-ARRAY-FROM-ARRAY JNEW-ARRAY-FROM-LIST JARRAY-FROM-LIST + JCLASS-CONSTRUCTORS JCONSTRUCTOR-PARAMS JCLASS-FIELD JCLASS-FIELDS + JFIELD-TYPE JFIELD-NAME JCLASS-METHODS JMETHOD-PARAMS JMETHOD-NAME + JINSTANCE-OF-P JMEMBER-STATIC-P JMEMBER-PUBLIC-P JMEMBER-PROTECTED-P + JNEW-RUNTIME-CLASS DEFINE-JAVA-CLASS ENSURE-JAVA-CLASS CHAIN + JMETHOD-LET JEQUAL)) + + + + (defun add-url-to-classpath (url &optional (classloader *classloader*)) (jcall "addUrl" classloader url)) From ehuelsmann at common-lisp.net Fri Aug 17 08:50:59 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 17 Aug 2012 01:50:59 -0700 Subject: [armedbear-cvs] r14105 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 17 01:50:58 2012 New Revision: 14105 Log: Break circular dependency between top-level.lisp and inspect.lisp by moving a few defvar forms. Modified: trunk/abcl/src/org/armedbear/lisp/inspect.lisp trunk/abcl/src/org/armedbear/lisp/top-level.lisp Modified: trunk/abcl/src/org/armedbear/lisp/inspect.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/inspect.lisp Fri Aug 17 01:48:50 2012 (r14104) +++ trunk/abcl/src/org/armedbear/lisp/inspect.lisp Fri Aug 17 01:50:58 2012 (r14105) @@ -32,9 +32,15 @@ (in-package #:system) (require 'clos) - (require 'format) + +(defvar *inspect-break* nil) +(defvar *inspected-object-stack* nil) +(defvar *inspected-object* nil) + + + (defun leader (name) (let ((size (max 0 (- 16 (length (string name)))))) (concatenate 'string (make-string size :initial-element #\-) "->"))) Modified: trunk/abcl/src/org/armedbear/lisp/top-level.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/top-level.lisp Fri Aug 17 01:48:50 2012 (r14104) +++ trunk/abcl/src/org/armedbear/lisp/top-level.lisp Fri Aug 17 01:50:58 2012 (r14105) @@ -31,16 +31,9 @@ ;;; Adapted from SB-ACLREPL (originally written by Kevin Rosenberg). -(in-package #:system) - -(defvar *inspect-break* nil) - -(defvar *inspected-object-stack* nil) - -(defvar *inspected-object* nil) - (in-package #:top-level) +(require 'inspect) (defvar *null-cmd* (gensym)) (defvar *handled-cmd* (gensym)) From ehuelsmann at common-lisp.net Fri Aug 17 10:45:01 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 17 Aug 2012 03:45:01 -0700 Subject: [armedbear-cvs] r14106 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 17 03:45:00 2012 New Revision: 14106 Log: Move exports from the THREADS package to threads.lisp. Move sockets related exports to socket.lisp, fixing symbol references to refer to the EXTENSIONS package instead of SYSTEM. Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp trunk/abcl/src/org/armedbear/lisp/ed.lisp trunk/abcl/src/org/armedbear/lisp/socket.lisp trunk/abcl/src/org/armedbear/lisp/threads.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Fri Aug 17 01:50:58 2012 (r14105) +++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Fri Aug 17 03:45:00 2012 (r14106) @@ -84,26 +84,6 @@ (export 'process-kill) (autoload 'process-kill "run-program") -(export 'make-socket) -(export 'make-server-socket) -(export 'server-socket-close) -(export 'socket-accept) -(export 'socket-close) -(export 'get-socket-stream) -(export 'socket-peer-port) -(export 'socket-local-port) -(export 'socket-local-address) -(export 'socket-peer-address) - -(in-package "THREADS") - -(export '(make-mailbox mailbox-send mailbox-empty-p - mailbox-read mailbox-peek)) -(export '(make-thread-lock with-thread-lock)) -(export '(make-mutex get-mutex release-mutex with-mutex)) - - -(in-package "EXTENSIONS") (export '(grovel-java-definitions compile-system)) (export 'aver) Modified: trunk/abcl/src/org/armedbear/lisp/ed.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ed.lisp Fri Aug 17 01:50:58 2012 (r14105) +++ trunk/abcl/src/org/armedbear/lisp/ed.lisp Fri Aug 17 03:45:00 2012 (r14106) @@ -57,8 +57,8 @@ stream) (when (probe-file portfile) (let* ((port (with-open-file (s portfile) (read s nil nil))) - (socket (and (integerp port) (make-socket "127.0.0.1" port)))) - (setf stream (and socket (get-socket-stream socket))))) + (socket (and (integerp port) (ext:make-socket "127.0.0.1" port)))) + (setf stream (and socket (ext:get-socket-stream socket))))) (unwind-protect (cond ((stringp what) (if stream Modified: trunk/abcl/src/org/armedbear/lisp/socket.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/socket.lisp Fri Aug 17 01:50:58 2012 (r14105) +++ trunk/abcl/src/org/armedbear/lisp/socket.lisp Fri Aug 17 03:45:00 2012 (r14106) @@ -29,7 +29,12 @@ ;;; obligated to do so. If you do not wish to do so, delete this ;;; exception statement from your version. -(in-package "SYSTEM") +(in-package "EXTENSIONS") + +(export '(make-socket make-server-socket server-socket-close socket-accept + socket-close get-socket-stream socket-peer-port socket-local-port + socket-local-address socket-peer-address)) + (defun get-socket-stream (socket &key (element-type 'character) (external-format :default)) ":ELEMENT-TYPE must be CHARACTER or (UNSIGNED-BYTE 8); the default is CHARACTER. @@ -42,22 +47,22 @@ (error 'simple-type-error :format-control ":ELEMENT-TYPE must be CHARACTER or (UNSIGNED-BYTE 8)."))) - (%socket-stream socket element-type external-format)) + (sys::%socket-stream socket element-type external-format)) (defun make-socket (host port) - (%make-socket host port)) + (sys::%make-socket host port)) (defun make-server-socket (port) - (%make-server-socket port)) + (sys::%make-server-socket port)) (defun socket-accept (socket) - (%socket-accept socket)) + (sys::%socket-accept socket)) (defun socket-close (socket) - (%socket-close socket)) + (sys::%socket-close socket)) (defun server-socket-close (socket) - (%server-socket-close socket)) + (sys::%server-socket-close socket)) (declaim (inline %socket-address %socket-port)) (defun %socket-address (socket addressName) Modified: trunk/abcl/src/org/armedbear/lisp/threads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/threads.lisp Fri Aug 17 01:50:58 2012 (r14105) +++ trunk/abcl/src/org/armedbear/lisp/threads.lisp Fri Aug 17 03:45:00 2012 (r14106) @@ -33,6 +33,12 @@ (in-package #:threads) +(export '(make-mailbox mailbox-send mailbox-empty-p + mailbox-read mailbox-peek + make-thread-lock with-thread-lock + make-mutex get-mutex release-mutex with-mutex)) + + ;; ;; MAKE-THREAD helper to establish restarts ;; From rschlatte at common-lisp.net Fri Aug 17 12:53:04 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Fri, 17 Aug 2012 05:53:04 -0700 Subject: [armedbear-cvs] r14107 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Fri Aug 17 05:53:04 2012 New Revision: 14107 Log: restore build - ed.lisp needs make-socket to be exported Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Fri Aug 17 03:45:00 2012 (r14106) +++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Fri Aug 17 05:53:04 2012 (r14107) @@ -282,6 +282,7 @@ (load (do-compile "ldb.lisp")) (load (do-compile "destructuring-bind.lisp")) (load (do-compile "asdf.lisp")) + (load (do-compile "socket.lisp")) ;; But not for these. (mapc #'do-compile '("abcl-contrib.lisp" "adjoin.lisp" @@ -399,7 +400,6 @@ "sets.lisp" "shiftf.lisp" "signal.lisp" - "socket.lisp" "sort.lisp" "step.lisp" "strings.lisp" From ehuelsmann at common-lisp.net Fri Aug 17 13:59:56 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 17 Aug 2012 06:59:56 -0700 Subject: [armedbear-cvs] r14108 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 17 06:59:55 2012 New Revision: 14108 Log: Remove tag-line from generated autoloads-gen.lisp. Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Fri Aug 17 05:53:04 2012 (r14107) +++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Fri Aug 17 06:59:55 2012 (r14108) @@ -190,7 +190,6 @@ (terpri f) (write-line ";; ---- GENERATED CONTENT BELOW" f) (terpri f) - (write '(identity T) :stream f) (dolist (package '(:format :sequence :loop :mop :xp :precompiler :profiler :java :jvm :extensions :threads :top-level :system :cl)) From ehuelsmann at common-lisp.net Fri Aug 17 14:17:41 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 17 Aug 2012 07:17:41 -0700 Subject: [armedbear-cvs] r14109 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 17 07:17:40 2012 New Revision: 14109 Log: Remove/move exports in their respective source files. Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Fri Aug 17 06:59:55 2012 (r14108) +++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Fri Aug 17 07:17:40 2012 (r14109) @@ -106,25 +106,6 @@ (in-package "SYSTEM") -;; #:SYSTEM in PRECOMPILER.LISP - - -(export '(process-optimization-declarations - inline-p notinline-p inline-expansion expand-inline - note-name-defined precompile)) - - - -;; #:SYSTEM in SOURCE-TRANSFORM.LISP - -(export '(source-transform define-source-transform expand-source-transform)) - -(in-package "PRECOMPILER") - -(export '(precompile-form precompile)) - - -(in-package "SYSTEM") ;; This one must be last, or at least past print-object and clos: ;; we don't want FORMATs executed before we can load those to end us Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Fri Aug 17 06:59:55 2012 (r14108) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Fri Aug 17 07:17:40 2012 (r14109) @@ -323,6 +323,10 @@ (in-package "PRECOMPILER") + +(export '(precompile-form precompile)) + + ;; No source-transforms and inlining in precompile-function-call ;; No macro expansion in precompile-dolist and precompile-dotimes ;; No macro expansion in precompile-do/do* From ehuelsmann at common-lisp.net Fri Aug 17 14:19:10 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 17 Aug 2012 07:19:10 -0700 Subject: [armedbear-cvs] r14110 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 17 07:19:10 2012 New Revision: 14110 Log: Bind *local-functions* to nil, since COMPILE-1 is the outer-most scope. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 17 07:17:40 2012 (r14109) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 17 07:19:10 2012 (r14110) @@ -7300,7 +7300,7 @@ (let ((*all-variables* nil) (*closure-variables* nil) (*undefined-variables* nil) - (*local-functions* *local-functions*)) + (*local-functions* nil)) (p1-compiland compiland) ;; *all-variables* doesn't contain variables which From ehuelsmann at common-lisp.net Fri Aug 17 16:02:53 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 17 Aug 2012 09:02:53 -0700 Subject: [armedbear-cvs] r14111 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 17 09:02:52 2012 New Revision: 14111 Log: Reverse the REQUIREs graph: before, modules would require JVM, which would require the rest of the compiler. That doesn't work with the automatic autoloader, because that requires the files in which symbol function bindings are located. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Fri Aug 17 07:19:10 2012 (r14110) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Fri Aug 17 09:02:52 2012 (r14111) @@ -31,8 +31,7 @@ (in-package #:system) -(require "JVM") -;; (require "COMPILER-ERROR") already made accessible through JVM +(require "COMPILER-PASS2") (defvar *fbound-names*) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Fri Aug 17 07:19:10 2012 (r14110) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Fri Aug 17 09:02:52 2012 (r14111) @@ -39,7 +39,6 @@ (require "KNOWN-FUNCTIONS") (require "KNOWN-SYMBOLS") (require "DUMP-FORM") -(require "OPCODES") (require "JAVA") Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 17 07:19:10 2012 (r14110) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 17 09:02:52 2012 (r14111) @@ -43,6 +43,8 @@ (require "DUMP-FORM") (require "JVM-INSTRUCTIONS") (require "JVM-CLASS-FILE") + (require "JVM") + (require "COMPILER-PASS1") (require "JAVA")) Modified: trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Fri Aug 17 07:19:10 2012 (r14110) +++ trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Fri Aug 17 09:02:52 2012 (r14111) @@ -32,6 +32,9 @@ (in-package #:jvm) +(require "COMPILER-ERROR") + + (declaim (inline u2 s1 s2)) (defknown u2 (fixnum) cons) Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp Fri Aug 17 07:19:10 2012 (r14110) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Fri Aug 17 09:02:52 2012 (r14111) @@ -34,21 +34,7 @@ (export '(compile-defun *catch-errors* jvm-compile-package derive-compiler-type)) -(eval-when (:compile-toplevel :load-toplevel :execute) - (require "LOOP") - (require "FORMAT") - (require "CLOS") - (require "PRINT-OBJECT") - (require "COMPILER-TYPES") - (require "COMPILER-ERROR") - (require "KNOWN-FUNCTIONS") - (require "DUMP-FORM") - (require "JVM-INSTRUCTIONS") - (require "JVM-CLASS-FILE") - (require "KNOWN-SYMBOLS") - (require "JAVA") - (require "COMPILER-PASS1") - (require "COMPILER-PASS2")) +(require "JVM-CLASS-FILE") (defvar *closure-variables* nil) From ehuelsmann at common-lisp.net Sat Aug 18 08:17:45 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 18 Aug 2012 01:17:45 -0700 Subject: [armedbear-cvs] r14112 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 18 01:17:42 2012 New Revision: 14112 Log: Use PROVIDE/REQUIRE to prevent multiple loading. Modified: trunk/abcl/src/org/armedbear/lisp/pprint-dispatch.lisp trunk/abcl/src/org/armedbear/lisp/pprint.lisp trunk/abcl/src/org/armedbear/lisp/print-object.lisp trunk/abcl/src/org/armedbear/lisp/print.lisp Modified: trunk/abcl/src/org/armedbear/lisp/pprint-dispatch.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/pprint-dispatch.lisp Fri Aug 17 09:02:52 2012 (r14111) +++ trunk/abcl/src/org/armedbear/lisp/pprint-dispatch.lisp Sat Aug 18 01:17:42 2012 (r14112) @@ -57,6 +57,8 @@ (in-package #:xp) +(require "PPRINT") + (defvar *ipd* nil ;see initialization at end of file. "initial print dispatch table.") @@ -333,3 +335,5 @@ (set-pprint-dispatch+ 'pprint-dispatch-table #'pprint-dispatch-print '(0) *ipd*) (setf *print-pprint-dispatch* (copy-pprint-dispatch nil)) + +(provide "PPRINT-DISPATCH") \ No newline at end of file Modified: trunk/abcl/src/org/armedbear/lisp/pprint.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/pprint.lisp Fri Aug 17 09:02:52 2012 (r14111) +++ trunk/abcl/src/org/armedbear/lisp/pprint.lisp Sat Aug 18 01:17:42 2012 (r14112) @@ -59,6 +59,8 @@ ;must do the following in common lisps not supporting *print-shared* +(require "PRINT") + (defvar *print-shared* nil) (export '(*print-shared*)) Modified: trunk/abcl/src/org/armedbear/lisp/print-object.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/print-object.lisp Fri Aug 17 09:02:52 2012 (r14111) +++ trunk/abcl/src/org/armedbear/lisp/print-object.lisp Sat Aug 18 01:17:42 2012 (r14112) @@ -121,4 +121,4 @@ (cell-error-name x))) (format stream "The variable ~S is unbound." (cell-error-name x)))) -(provide 'print-object) +(provide "PRINT-OBJECT") Modified: trunk/abcl/src/org/armedbear/lisp/print.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/print.lisp Fri Aug 17 09:02:52 2012 (r14111) +++ trunk/abcl/src/org/armedbear/lisp/print.lisp Sat Aug 18 01:17:42 2012 (r14112) @@ -314,3 +314,5 @@ (t (%print-object object stream))) object) + +(provide "PRINT") \ No newline at end of file From ehuelsmann at common-lisp.net Sat Aug 18 08:19:56 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 18 Aug 2012 01:19:56 -0700 Subject: [armedbear-cvs] r14113 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 18 01:19:56 2012 New Revision: 14113 Log: Merge StandardObjectFunctions into StandardObject: the former defines a single Primitive while the latter defines multiple. Also, add all the defined primitives to the java-autoloader. Deleted: trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/StandardObject.java Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java Sat Aug 18 01:17:42 2012 (r14112) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Sat Aug 18 01:19:56 2012 (r14113) @@ -564,6 +564,8 @@ autoload(PACKAGE_SYS, "%run-shell-command", "ShellCommand"); autoload(PACKAGE_SYS, "%server-socket-close", "server_socket_close"); autoload(PACKAGE_SYS, "%set-arglist", "arglist"); + autoload(PACKAGE_CL, "find-class", "LispClass", true); + autoload(PACKAGE_SYS, "%set-find-class", "LispClass", true); autoload(PACKAGE_SYS, "%set-class-direct-slots", "SlotClass", true); autoload(PACKAGE_SYS, "%set-function-info", "function_info"); autoload(PACKAGE_SYS, "%set-generic-function-lambda-list", "StandardGenericFunction", true); @@ -618,7 +620,7 @@ autoload(PACKAGE_SYS, "cache-slot-location", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "canonicalize-logical-host", "LogicalPathname", true); autoload(PACKAGE_SYS, "class-direct-slots", "SlotClass"); - autoload(PACKAGE_SYS, "%float-bits", "FloatFunctions"); + autoload(PACKAGE_SYS, "%float-bits", "FloatFunctions"); autoload(PACKAGE_SYS, "coerce-to-double-float", "FloatFunctions"); autoload(PACKAGE_SYS, "coerce-to-single-float", "FloatFunctions"); autoload(PACKAGE_SYS, "compute-class-direct-slots", "SlotClass", true); @@ -683,7 +685,16 @@ autoload(PACKAGE_SYS, "set-slot-definition-writers", "SlotDefinition", true); autoload(PACKAGE_SYS, "simple-list-remove-duplicates", "simple_list_remove_duplicates"); autoload(PACKAGE_SYS, "single-float-bits", "FloatFunctions", true); - autoload(PACKAGE_SYS, "%std-allocate-instance", "StandardObjectFunctions", true); + autoload(PACKAGE_SYS, "%std-allocate-instance", "StandardObject", true); + autoload(PACKAGE_SYS, "swap-slots", "StandardObject", true); + autoload(PACKAGE_SYS, "std-instance-layout", "StandardObject", true); + autoload(PACKAGE_SYS, "%set-std-instance-layout", "StandardObject", true); + autoload(PACKAGE_SYS, "std-instance-class", "StandardObject", true); + autoload(PACKAGE_SYS, "standard-instance-access", "StandardObject", true); + autoload(PACKAGE_SYS, "%set-standard-instance-access", "StandardObject", true); + autoload(PACKAGE_SYS, "std-slot-boundp", "StandardObject", true); + autoload(PACKAGE_SYS, "std-slot-value", "StandardObject", true); + autoload(PACKAGE_SYS, "set-std-slot-value", "StandardObject", true); autoload(PACKAGE_SYS, "%allocate-funcallable-instance", "FuncallableStandardObject", true); autoload(PACKAGE_SYS, "unzip", "unzip", true); autoload(PACKAGE_SYS, "zip", "zip", true); Modified: trunk/abcl/src/org/armedbear/lisp/StandardObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardObject.java Sat Aug 18 01:17:42 2012 (r14112) +++ trunk/abcl/src/org/armedbear/lisp/StandardObject.java Sat Aug 18 01:19:56 2012 (r14113) @@ -615,4 +615,33 @@ return third; } }; + + private static final Primitive _STD_ALLOCATE_INSTANCE + = new pf__std_allocate_instance(); + @DocString(name="%std-allocate-instance", + args="class", + returns="instance") + private static final class pf__std_allocate_instance extends Primitive + { + pf__std_allocate_instance() + { + super("%std-allocate-instance", PACKAGE_SYS, true, "class"); + } + @Override + public LispObject execute(LispObject arg) + { + if (arg == StandardClass.STANDARD_CLASS) + return new StandardClass(); + if (arg instanceof StandardClass) + return ((StandardClass)arg).allocateInstance(); + if (arg.typep(StandardClass.STANDARD_CLASS) != NIL) { + LispObject l = Symbol.CLASS_LAYOUT.execute(arg); + if (! (l instanceof Layout)) + return error(new ProgramError("Invalid standard class layout for: " + arg.princToString())); + + return new StandardObject((Layout)l); + } + return type_error(arg, Symbol.STANDARD_CLASS); + } + }; } From ehuelsmann at common-lisp.net Sat Aug 18 08:23:08 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 18 Aug 2012 01:23:08 -0700 Subject: [armedbear-cvs] r14114 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 18 01:23:08 2012 New Revision: 14114 Log: Modules defining PRINT-OBJECT methods, should require PRINT-OBJECT. Make java-collections.lisp do so. Modified: trunk/abcl/src/org/armedbear/lisp/java-collections.lisp Modified: trunk/abcl/src/org/armedbear/lisp/java-collections.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/java-collections.lisp Sat Aug 18 01:19:56 2012 (r14113) +++ trunk/abcl/src/org/armedbear/lisp/java-collections.lisp Sat Aug 18 01:23:08 2012 (r14114) @@ -1,6 +1,7 @@ (require "CLOS") (require "JAVA") (require "EXTENSIBLE-SEQUENCES") +(require "PRINT-OBJECT") (in-package :java) From ehuelsmann at common-lisp.net Sat Aug 18 10:35:03 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 18 Aug 2012 03:35:03 -0700 Subject: [armedbear-cvs] r14115 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 18 03:35:03 2012 New Revision: 14115 Log: Move export from autoloads.lisp to clos.lisp. Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Sat Aug 18 01:23:08 2012 (r14114) +++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Sat Aug 18 03:35:03 2012 (r14115) @@ -51,9 +51,6 @@ (export '%ldb '#:system) (export 'concatenate-to-string '#:system) -(in-package "MOP") -(export '(%defgeneric - canonicalize-direct-superclasses)) ;; Profiler. (in-package "PROFILER") Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Aug 18 01:23:08 2012 (r14114) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Aug 18 03:35:03 2012 (r14115) @@ -52,6 +52,9 @@ (in-package #:mop) +(export '(%defgeneric canonicalize-direct-superclasses)) + + ;; ;; ;; @@ -4586,5 +4589,5 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (require "MOP")) -(provide 'clos) +(provide "CLOS") From ehuelsmann at common-lisp.net Sat Aug 18 10:36:45 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 18 Aug 2012 03:36:45 -0700 Subject: [armedbear-cvs] r14116 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 18 03:36:44 2012 New Revision: 14116 Log: Make compile-file generate a file with EXPORTed symbols so we can use it in COMPILE-SYSTEM. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sat Aug 18 03:35:03 2012 (r14115) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sat Aug 18 03:36:44 2012 (r14116) @@ -41,6 +41,7 @@ (defvar *toplevel-functions*) (defvar *toplevel-macros*) +(defvar *toplevel-exports*) (defun base-classname (&optional (output-file-pathname *output-file-pathname*)) @@ -281,6 +282,16 @@ (eval form))) nil) +(declaim (ftype (function (t t t) t) process-toplevel-export)) +(defun process-toplevel-export (form stream compile-time-too) + (when (eq (car (second form)) 'QUOTE) ;; constant export list + (let ((sym-or-syms (second (second form)))) + (setf *toplevel-exports* + (append *toplevel-exports* (if (listp sym-or-syms) + sym-or-syms + (list sym-or-syms)))))) + (precompile-toplevel-form form stream compile-time-too)) + (declaim (ftype (function (t t t) t) process-toplevel-mop.ensure-method)) (defun process-toplevel-mop.ensure-method (form stream compile-time-too) (declare (ignore stream)) @@ -561,7 +572,7 @@ (DEFUN process-toplevel-defun) (DEFVAR process-toplevel-defvar/defparameter) (EVAL-WHEN process-toplevel-eval-when) - (EXPORT precompile-toplevel-form) + (EXPORT process-toplevel-export) (IMPORT process-toplevel-import) (IN-PACKAGE process-toplevel-defpackage/in-package) (LOCALLY process-toplevel-locally) @@ -697,7 +708,7 @@ (defun compile-from-stream (in output-file temp-file temp-file2 extract-toplevel-funcs-and-macros - functions-file macros-file) + functions-file macros-file exports-file) (let* ((*compile-file-pathname* (make-pathname :defaults (pathname in) :version nil)) (*compile-file-truename* (make-pathname :defaults (truename in) @@ -776,7 +787,20 @@ :if-does-not-exist :create :if-exists :supersede) (let ((*package* (find-package :keyword))) - (write *toplevel-macros* :stream m-out))))) + (write *toplevel-macros* :stream m-out)))) + (setf *toplevel-exports* + (remove-if-not (lambda (sym) + (if (symbolp sym) + (symbol-package sym) + T)) + (remove-duplicates *toplevel-exports*))) + (when *toplevel-exports* + (with-open-file (e-out exports-file + :direction :output + :if-does-not-exist :create + :if-exists :supersede) + (let ((*package* (find-package :keyword))) + (write *toplevel-exports* :stream e-out))))) (with-open-file (in temp-file :direction :input) (with-open-file (out temp-file2 :direction :output :if-does-not-exist :create @@ -863,14 +887,16 @@ (temp-file2 (pathname-with-type output-file type "-tmp2")) (functions-file (pathname-with-type output-file "funcs")) (macros-file (pathname-with-type output-file "macs")) + (exports-file (pathname-with-type output-file "exps")) *toplevel-functions* *toplevel-macros* + *toplevel-exports* (warnings-p nil) (failure-p nil)) (with-open-file (in input-file :direction :input) (compile-from-stream in output-file temp-file temp-file2 extract-toplevel-funcs-and-macros - functions-file macros-file)) + functions-file macros-file exports-file)) (values (truename output-file) warnings-p failure-p)))) (defun compile-file-if-needed (input-file &rest allargs &key force-compile From ehuelsmann at common-lisp.net Sat Aug 18 10:49:15 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 18 Aug 2012 03:49:15 -0700 Subject: [armedbear-cvs] r14117 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 18 03:49:15 2012 New Revision: 14117 Log: 3 changes: - Improve speed of "multi-homed symbol" removal - Generate autoloader EXPORT commands based on EXPORTed symbols in the compiled files, instead of on the symbols currently exported (this one fixes the SLIME MAKE-THREAD-LOCK issue) - Reverse the "multi-homed filtering" and the "autoloads file exclusion" in order to stop considering symbols overridden by extensible sequences (e.g. COUNT-IF, REMOVE, etc) as being multi-homed: we want to autoload the non-extensible versions by default. Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Sat Aug 18 03:36:44 2012 (r14116) +++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Sat Aug 18 03:49:15 2012 (r14117) @@ -90,10 +90,18 @@ (mapcar #'second combos))))) (defun remove-multi-combo-symbols (combos) - (remove-if (lambda (x) - (< 1 (count x combos :key #'second))) - combos - :key #'second)) + (princ "; Removing multi-homed symbols") + (let ((sym-hash (make-hash-table :size (* 2 (length combos))))) + (dolist (combo combos) + (incf (gethash (second combo) sym-hash 0))) + (print (remove-if-not (lambda (x) + (< 1 (gethash x sym-hash))) + combos + :key #'second)) + (remove-if (lambda (x) + (< 1 (gethash x sym-hash))) + combos + :key #'second))) (defun set-equal (set1 set2 &key test) (or (eq set1 set2) @@ -118,7 +126,8 @@ :key #'first) (pushnew (first symbol-fileset) (cdr (assoc (cdr symbol-fileset) fileset-symbols - :test (lambda (x y) (set-equal x y :test #'string=)))))) + :test (lambda (x y) + (set-equal x y :test #'string=)))))) fileset-symbols)) (defun write-autoloader (stream package type fileset-symbols) @@ -163,25 +172,34 @@ (defun generate-autoloads (symbol-files-pathspec) (flet ((filter-combos (combos) - (remove-if (lambda (x) - ;; exclude the symbols from the files - ;; below: putting autoloaders on some of - ;; the symbols conflicts with the bootstrapping - ;; Primitives which have been defined Java-side - (member x '( ;; function definitions to be excluded - "fdefinition" "early-defuns" - "require" "signal" - "extensible-sequences-base" "restart" - "extensible-sequences" - ;; macro definitions to be excluded - "macros" "backquote" "precompiler") - :test #'string=)) - (remove-multi-combo-symbols combos) - :key #'first)) + (remove-multi-combo-symbols + (remove-if (lambda (x) + ;; exclude the symbols from the files + ;; below: putting autoloaders on some of + ;; the symbols conflicts with the bootstrapping + ;; Primitives which have been defined Java-side + (member x '( ;; function definitions to be excluded + "fdefinition" "early-defuns" + "require" "signal" "restart" + + ;; extensible sequences override + ;; lots of default functions; + ;; java-collections implements + ;; extensible sequences + "extensible-sequences-base" + "extensible-sequences" "java-collections" + + ;; macro definitions to be excluded + "macros" ;; "backquote" + "precompiler") + :test #'string=)) + combos + :key #'first))) (symbols-pathspec (filespec) (merge-pathnames filespec symbol-files-pathspec))) (let ((funcs (filter-combos (load-combos (symbols-pathspec "*.funcs")))) - (macs (filter-combos (load-combos (symbols-pathspec "*.macs"))))) + (macs (filter-combos (load-combos (symbols-pathspec "*.macs")))) + (exps (filter-combos (load-combos (symbols-pathspec "*.exps"))))) (with-open-file (f (symbols-pathspec "autoloads-gen.lisp") :direction :output :if-does-not-exist :create :if-exists :supersede) @@ -198,13 +216,13 @@ ;; and ASDF are not being created. Nor are these packages ;; vital to the correct operation of the base system. - (let ((*package* (find-package package)) - externals) - (do-external-symbols (sym package - externals) - (when (eq (symbol-package sym) - *package*) - (push sym externals))) + (let* ((*package* (find-package package)) + (all-exported-symbols + (remove-duplicates (mapcar #'second exps))) + (externals (remove-if-not (lambda (sym) + (eq (symbol-package sym) + *package*)) + all-exported-symbols))) (when externals (write-line ";; EXPORTS" f) (write `(cl:in-package ,package) :stream f) From ehuelsmann at common-lisp.net Sat Aug 18 11:04:18 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 18 Aug 2012 04:04:18 -0700 Subject: [armedbear-cvs] r14118 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 18 04:04:18 2012 New Revision: 14118 Log: Update autoloads-gen.lisp to include the auto-groveled EXPORT forms. Note: This file no longer required manual intervention to work as a bootstrapping file. Yay! Modified: trunk/abcl/src/org/armedbear/lisp/autoloads-gen.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads-gen.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads-gen.lisp Sat Aug 18 03:49:15 2012 (r14117) +++ trunk/abcl/src/org/armedbear/lisp/autoloads-gen.lisp Sat Aug 18 04:04:18 2012 (r14118) @@ -4,59 +4,168 @@ ;; 'autoloads.lisp' only contains the manual additions. ;; The content has been generated using the same code as the code which -;; is used at build-time. However, this file has been tweaked to allow -;; the ant target to load its files without problems. +;; is used at build-time. ;; Generation of an file up-to-date file is part of the build process ;; and that file is included in abcl.jar. + +;; ---- GENERATED CONTENT BELOW + + +;; FUNCTIONS + (IN-PACKAGE :FORMAT) (DOLIST (SYSTEM::FS (QUOTE ((("format") %PRINT-FORMAT-ERROR MISSING-ARG MAKE-FORMAT-DIRECTIVE FORMAT-DIRECTIVE-P TOKENIZE-CONTROL-STRING PARSE-DIRECTIVE %FORMATTER EXPAND-CONTROL-STRING EXPAND-DIRECTIVE-LIST EXPAND-DIRECTIVE EXPAND-NEXT-ARG %SET-FORMAT-DIRECTIVE-EXPANDER %SET-FORMAT-DIRECTIVE-INTERPRETER FIND-DIRECTIVE A-FORMAT-DIRECTIVE-EXPANDER S-FORMAT-DIRECTIVE-EXPANDER C-FORMAT-DIRECTIVE-EXPANDER W-FORMAT-DIRECTIVE-EXPANDER EXPAND-FORMAT-INTEGER D-FORMAT-DIRECTIVE-EXPANDER B-FORMAT-DIRECTIVE-EXPANDER O-FORMAT-DIRECTIVE-EXPANDER X-FORMAT-DIRECTIVE-EXPANDER R-FORMAT-DIRECTIVE-EXPANDER P-FORMAT-DIRECTIVE-EXPANDER F-FORMAT-DIRECTIVE-EXPANDER E-FORMAT-DIRECTIVE-EXPANDER G-FORMAT-DIRECTIVE-EXPANDER $-FORMAT-DIRECTIVE-EXPANDER %-FORMAT-DIRECTIVE-EXPANDER &-FORMAT-DIRECTIVE-EXPANDER |\|-FORMAT-DIRECTIVE-EXPANDER| ~-FORMAT-DIRECTIVE-EXPANDER |Newline-FORMAT-DIRECTIVE-EXPANDER| T-FORMAT-DIRECTIVE-EXPANDER _-FORMAT-DIRECTIVE-EXPANDER I-FORMAT-DIRECTIVE-EXPANDER *-FORMAT-DIRECTIVE-EXPANDER ?-FORMAT-DIRECTIVE-EXPANDER |(-FORMAT-DIRECTIVE-EXPANDER| |)-FORMAT-DIRECTIVE-EXPANDER| [-FORMAT-DIRECTIVE-EXPANDER PARSE-CONDITIONAL-DIRECTIVE EXPAND-MAYBE-CONDITIONAL EXPAND-TRUE-FALSE-CONDITIONAL |;-FORMAT-DIRECTIVE-EXPANDER| ]-FORMAT-DIRECTIVE-EXPANDER ^-FORMAT-DIRECTIVE-EXPANDER {-FORMAT-DIRECTIVE-EXPANDER }-FORMAT-DIRECTIVE-EXPANDER ILLEGAL-INSIDE-JUSTIFICATION-P <-FORMAT-DIRECTIVE-EXPANDER >-FORMAT-DIRECTIVE-EXPANDER PARSE-FORMAT-LOGICAL-BLOCK ADD-FILL-STYLE-NEWLINES ADD-FILL-STYLE-NEWLINES-AUX PARSE-FORMAT-JUSTIFICATION EXPAND-FORMAT-LOGICAL-BLOCK EXPAND-FORMAT-JUSTIFICATION /-FORMAT-DIRECTIVE-EXPANDER EXTRACT-USER-FUN-NAME %COMPILER-WALK-FORMAT-STRING %FORMAT INTERPRET-DIRECTIVE-LIST FORMAT-WRITE-FIELD FORMAT-PRINC A-FORMAT-DIRECTIVE-INTERPRETER FORMAT-PRIN1 S-FORMAT-DIRECTIVE-INTERPRETER C-FORMAT-DIRECTIVE-INTERPRETER FORMAT-PRINT-NAMED-CHARACTER W-FORMAT-DIRECTIVE-INTERPRETER FORMAT-PRINT-INTEGER FORMAT-ADD-COMMAS D-FORMAT-DIRECTIVE-INTERPRETER B-FORMAT-DIRECTIVE-INTERPRETER O-FORMAT-DIRECTIVE-INTERPRETER X-FORMAT-DIRECTIVE-INTERPRETER R-FORMAT-DIRECTIVE-INTERPRETER FORMAT-PRINT-SMALL-CARDINAL FORMAT-PRINT-CARDINAL FORMAT-PRINT-CARDINAL-AUX FORMAT-PRINT-ORDINAL FORMAT-PRINT-OLD-ROMAN FORMAT-PRINT-ROMAN P-FORMAT-DIRECTIVE-INTERPRETER DECIMAL-STRING F-FORMAT-DIRECTIVE-INTERPRETER FORMAT-FIXED FORMAT-FIXED-AUX E-FORMAT-DIRECTIVE-INTERPRETER FORMAT-EXPONENTIAL FORMAT-EXPONENT-MARKER FORMAT-EXP-AUX G-FORMAT-DIRECTIVE-INTERPRETER FORMAT-GENERAL FORMAT-GENERAL-AUX $-FORMAT-DIRECTIVE-INTERPRETER FORMAT-DOLLARS %-FORMAT-DIRECTIVE-INTERPRETER &-FORMAT-DIRECTIVE-INTERPRETER |\|-FORMAT-DIRECTIVE-INTERPRETER| ~-FORMAT-DIRECTIVE-INTERPRETER |Newline-FORMAT-DIRECTIVE-INTERPRETER| T-FORMAT-DIRECTIVE-INTERPRETER OUTPUT-SPACES FORMAT-RELATIVE-TAB FORMAT-ABSOLUTE-TAB _-FORMAT-DIRECTIVE-INTERPRETER I-FORMAT-DIRECTIVE-INTERPRETER *-FORMAT-DIRECTIVE-INTERPRETER ?-FORMAT-DIRECTIVE-INTERPRETER |(-FORMAT-DIRECTIVE-INTERPRETER| |)-FORMAT-DIRECTIVE-INTERPRETER| [-FORMAT-DIRECTIVE-INTERPRETER |;-FORMAT-DIRECTIVE-INTERPRETER| ]-FORMAT-DIRECTIVE-INTERPRETER ^-FORMAT-DIRECTIVE-INTERPRETER {-FORMAT-DIRECTIVE-INTERPRETER }-FORMAT-DIRECTIVE-INTERPRETER <-FORMAT-DIRECTIVE-INTERPRETER INTERPRET-FORMAT-JUSTIFICATION FORMAT-JUSTIFICATION INTERPRET-FORMAT-LOGICAL-BLOCK /-FORMAT-DIRECTIVE-INTERPRETER)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) + +;; MACROS + (IN-PACKAGE :FORMAT) (DOLIST (SYSTEM::FS (QUOTE ((("format") EXPANDER-NEXT-ARG EXPAND-BIND-DEFAULTS DEF-COMPLEX-FORMAT-DIRECTIVE DEF-FORMAT-DIRECTIVE EXPANDER-PPRINT-NEXT-ARG INTERPRET-FORMAT-INTEGER)))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) -(IN-PACKAGE :SEQUENCE) -(DOLIST (SYSTEM::FS (QUOTE ( ))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) -(IN-PACKAGE :SEQUENCE) -(DOLIST (SYSTEM::FS (QUOTE ( ))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) + +;; FUNCTIONS + + +;; MACROS + + +;; FUNCTIONS + (IN-PACKAGE :LOOP) (DOLIST (SYSTEM::FS (QUOTE ((("loop") MAKE-LOOP-MINIMAX-INTERNAL MAKE-LOOP-MINIMAX LOOP-NOTE-MINIMAX-OPERATION LOOP-TEQUAL LOOP-TASSOC LOOP-TMEMBER LOOP-LOOKUP-KEYWORD MAKE-LOOP-UNIVERSE MAKE-STANDARD-LOOP-UNIVERSE LOOP-MAKE-PSETQ LOOP-MAKE-DESETQ LOOP-CONSTANT-FOLD-IF-POSSIBLE LOOP-CONSTANTP LOOP-CODE-DUPLICATION-THRESHOLD DUPLICATABLE-CODE-P DESTRUCTURING-SIZE ESTIMATE-CODE-SIZE ESTIMATE-CODE-SIZE-1 LOOP-CONTEXT LOOP-ERROR LOOP-WARN LOOP-CHECK-DATA-TYPE SUBST-GENSYMS-FOR-NIL LOOP-BUILD-DESTRUCTURING-BINDINGS LOOP-TRANSLATE LOOP-ITERATION-DRIVER LOOP-POP-SOURCE LOOP-GET-FORM LOOP-GET-COMPOUND-FORM LOOP-GET-PROGN LOOP-CONSTRUCT-RETURN LOOP-PSEUDO-BODY LOOP-EMIT-BODY LOOP-EMIT-FINAL-VALUE LOOP-DISALLOW-CONDITIONAL LOOP-DISALLOW-ANONYMOUS-COLLECTORS LOOP-DISALLOW-AGGREGATE-BOOLEANS LOOP-TYPED-INIT LOOP-OPTIONAL-TYPE LOOP-BIND-BLOCK LOOP-VAR-P LOOP-MAKE-VAR LOOP-MAKE-ITERATION-VAR LOOP-DECLARE-VAR LOOP-MAYBE-BIND-FORM LOOP-DO-IF LOOP-DO-INITIALLY LOOP-DO-FINALLY LOOP-DO-DO LOOP-DO-NAMED LOOP-DO-RETURN MAKE-LOOP-COLLECTOR LOOP-GET-COLLECTION-INFO LOOP-LIST-COLLECTION LOOP-SUM-COLLECTION LOOP-MAXMIN-COLLECTION LOOP-DO-ALWAYS LOOP-DO-THEREIS LOOP-DO-WHILE LOOP-DO-REPEAT LOOP-DO-WITH LOOP-HACK-ITERATION LOOP-DO-FOR LOOP-WHEN-IT-VAR LOOP-ANSI-FOR-EQUALS LOOP-FOR-ACROSS LOOP-LIST-STEP LOOP-FOR-ON LOOP-FOR-IN MAKE-LOOP-PATH ADD-LOOP-PATH LOOP-FOR-BEING LOOP-NAMED-VAR LOOP-COLLECT-PREPOSITIONAL-PHRASES LOOP-SEQUENCER LOOP-FOR-ARITHMETIC LOOP-SEQUENCE-ELEMENTS-PATH LOOP-HASH-TABLE-ITERATION-PATH LOOP-PACKAGE-SYMBOLS-ITERATION-PATH MAKE-ANSI-LOOP-UNIVERSE LOOP-STANDARD-EXPANSION)))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) + +;; MACROS + (IN-PACKAGE :LOOP) (DOLIST (SYSTEM::FS (QUOTE ((("loop") WITH-LOOP-LIST-COLLECTION-HEAD LOOP-COLLECT-RPLACD LOOP-COLLECT-ANSWER WITH-MINIMAX-VALUE LOOP-ACCUMULATE-MINIMAX-VALUE LOOP-STORE-TABLE-DATA LOOP-REALLY-DESETQ LOOP-BODY LOOP-DESTRUCTURING-BIND)))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +;; EXPORTS +(IN-PACKAGE :MOP) +(EXPORT (QUOTE (CANONICALIZE-DIRECT-SUPERCLASSES %DEFGENERIC UPDATE-DEPENDENT MAP-DEPENDENTS REMOVE-DEPENDENT ADD-DEPENDENT EXTRACT-SPECIALIZER-NAMES EXTRACT-LAMBDA-LIST FIND-METHOD-COMBINATION REMOVE-DIRECT-METHOD ADD-DIRECT-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS SPECIALIZER-DIRECT-METHODS EQL-SPECIALIZER-OBJECT INTERN-EQL-SPECIALIZER FUNCALLABLE-STANDARD-INSTANCE-ACCESS SLOT-DEFINITION-WRITERS SLOT-DEFINITION-TYPE SLOT-DEFINITION-READERS SLOT-DEFINITION-NAME SLOT-DEFINITION-LOCATION SLOT-DEFINITION-INITFUNCTION SLOT-DEFINITION-INITFORM SLOT-DEFINITION-INITARGS SLOT-DEFINITION-ALLOCATION EFFECTIVE-SLOT-DEFINITION-CLASS DIRECT-SLOT-DEFINITION-CLASS WRITER-METHOD-CLASS READER-METHOD-CLASS ACCESSOR-METHOD-SLOT-DEFINITION METHOD-SPECIALIZERS METHOD-LAMBDA-LIST METHOD-GENERIC-FUNCTION METHOD-FUNCTION GENERIC-FUNCTION-NAME GENERIC-FUNCTION-METHOD-COMBINATION GENERIC-FUNCTION-METHOD-CLASS GENERIC-FUNCTION-LAMBDA-LIST GENERIC-FUNCTION-DECLARATIONS GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER REMOVE-DIRECT-SUBCLASS ADD-DIRECT-SUBCLASS CLASS-SLOTS CLASS-PROTOTYPE CLASS-PRECEDENCE-LIST CLASS-FINALIZED-P CLASS-DIRECT-SUPERCLASSES CLASS-DIRECT-SUBCLASSES CLASS-DIRECT-SLOTS CLASS-DIRECT-DEFAULT-INITARGS CLASS-DEFAULT-INITARGS ENSURE-GENERIC-FUNCTION-USING-CLASS ENSURE-CLASS-USING-CLASS ENSURE-CLASS SLOT-MAKUNBOUND-USING-CLASS SLOT-BOUNDP-USING-CLASS SLOT-VALUE-USING-CLASS VALIDATE-SUPERCLASS FINALIZE-INHERITANCE COMPUTE-SLOTS MAKE-METHOD-LAMBDA COMPUTE-EFFECTIVE-METHOD COMPUTE-APPLICABLE-METHODS-USING-CLASSES COMPUTE-DISCRIMINATING-FUNCTION COMPUTE-EFFECTIVE-SLOT-DEFINITION COMPUTE-DEFAULT-INITARGS COMPUTE-CLASS-PRECEDENCE-LIST STANDARD-WRITER-METHOD STANDARD-READER-METHOD STANDARD-ACCESSOR-METHOD FUNCALLABLE-STANDARD-CLASS FUNCALLABLE-STANDARD-OBJECT))) + +;; FUNCTIONS + (IN-PACKAGE :MOP) -(DOLIST (SYSTEM::FS (QUOTE ((("clos") CLASS-SLOTS CLASS-DIRECT-SLOTS CLASS-LAYOUT CLASS-DIRECT-SUPERCLASSES CLASS-DIRECT-SUBCLASSES CLASS-DIRECT-METHODS CLASS-PRECEDENCE-LIST CLASS-FINALIZED-P CLASS-DEFAULT-INITARGS CLASS-DIRECT-DEFAULT-INITARGS ADD-DIRECT-SUBCLASS REMOVE-DIRECT-SUBCLASS FIXUP-STANDARD-CLASS-HIERARCHY MAP-DEPENDENTS MAPAPPEND MAPPLIST FUNCALLABLE-STANDARD-INSTANCE-ACCESS CANONICALIZE-DIRECT-SLOTS CANONICALIZE-DIRECT-SLOT MAYBE-NOTE-NAME-DEFINED CANONICALIZE-DEFCLASS-OPTIONS CANONICALIZE-DEFCLASS-OPTION MAKE-INITFUNCTION SLOT-DEFINITION-ALLOCATION SLOT-DEFINITION-INITARGS SLOT-DEFINITION-INITFORM SLOT-DEFINITION-INITFUNCTION SLOT-DEFINITION-NAME SLOT-DEFINITION-READERS SLOT-DEFINITION-WRITERS SLOT-DEFINITION-ALLOCATION-CLASS SLOT-DEFINITION-LOCATION SLOT-DEFINITION-TYPE SLOT-DEFINITION-DOCUMENTATION INIT-SLOT-DEFINITION DIRECT-SLOT-DEFINITION-CLASS MAKE-DIRECT-SLOT-DEFINITION EFFECTIVE-SLOT-DEFINITION-CLASS MAKE-EFFECTIVE-SLOT-DEFINITION COMPUTE-DEFAULT-INITARGS STD-COMPUTE-DEFAULT-INITARGS STD-FINALIZE-INHERITANCE FINALIZE-INHERITANCE STD-COMPUTE-CLASS-PRECEDENCE-LIST TOPOLOGICAL-SORT STD-TIE-BREAKER-RULE COLLECT-SUPERCLASSES* LOCAL-PRECEDENCE-ORDERING STD-COMPUTE-SLOTS STD-COMPUTE-EFFECTIVE-SLOT-DEFINITION FIND-SLOT-DEFINITION SLOT-LOCATION INSTANCE-SLOT-LOCATION %SET-SLOT-VALUE STD-SLOT-MAKUNBOUND STD-SLOT-EXISTS-P INSTANCE-SLOT-P STD-ALLOCATE-INSTANCE ALLOCATE-FUNCALLABLE-INSTANCE CLASS-PROTOTYPE MAYBE-FINALIZE-CLASS-SUBTREE MAKE-INSTANCE-STANDARD-CLASS STD-AFTER-INITIALIZATION-FOR-CLASSES EXPAND-LONG-DEFCOMBIN %MAKE-LONG-METHOD-COMBINATION METHOD-COMBINATION-NAME METHOD-COMBINATION-DOCUMENTATION SHORT-METHOD-COMBINATION-OPERATOR SHORT-METHOD-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT LONG-METHOD-COMBINATION-LAMBDA-LIST LONG-METHOD-COMBINATION-METHOD-GROUP-SPECS LONG-METHOD-COMBINATION-ARGS-LAMBDA-LIST LONG-METHOD-COMBINATION-GENERIC-FUNCTION-SYMBOL LONG-METHOD-COMBINATION-FUNCTION LONG-METHOD-COMBINATION-ARGUMENTS LONG-METHOD-COMBINATION-DECLARATIONS LONG-METHOD-COMBINATION-FORMS EXPAND-SHORT-DEFCOMBIN METHOD-GROUP-P CHECK-VARIABLE-NAME CANONICALIZE-METHOD-GROUP-SPEC EXTRACT-REQUIRED-PART EXTRACT-SPECIFIED-PART EXTRACT-OPTIONAL-PART PARSE-DEFINE-METHOD-COMBINATION-ARGUMENTS-LAMBDA-LIST WRAP-WITH-CALL-METHOD-MACRO ASSERT-UNAMBIGUOUS-METHOD-SORTING METHOD-COMBINATION-TYPE-LAMBDA DECLARATIONP LONG-FORM-METHOD-COMBINATION-ARGS DEFINE-LONG-FORM-METHOD-COMBINATION STD-FIND-METHOD-COMBINATION FIND-METHOD-COMBINATION INTERN-EQL-SPECIALIZER EQL-SPECIALIZER-OBJECT STD-METHOD-FUNCTION STD-METHOD-GENERIC-FUNCTION STD-METHOD-SPECIALIZERS STD-METHOD-QUALIFIERS STD-ACCESSOR-METHOD-SLOT-DEFINITION STD-METHOD-FAST-FUNCTION STD-FUNCTION-KEYWORDS METHOD-GENERIC-FUNCTION METHOD-FUNCTION METHOD-SPECIALIZERS GENERIC-FUNCTION-NAME GENERIC-FUNCTION-LAMBDA-LIST GENERIC-FUNCTION-METHODS GENERIC-FUNCTION-METHOD-CLASS GENERIC-FUNCTION-METHOD-COMBINATION GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER CLASSES-TO-EMF-TABLE METHOD-DOCUMENTATION CANONICALIZE-DEFGENERIC-OPTIONS CANONICALIZE-DEFGENERIC-OPTION ARGUMENT-PRECEDENCE-ORDER-INDICES FIND-GENERIC-FUNCTION LAMBDA-LISTS-CONGRUENT-P COLLECT-EQL-SPECIALIZER-OBJECTS FINALIZE-STANDARD-GENERIC-FUNCTION MAKE-INSTANCE-STANDARD-GENERIC-FUNCTION CANONICALIZE-SPECIALIZERS CANONICALIZE-SPECIALIZER PARSE-DEFMETHOD REQUIRED-PORTION EXTRACT-LAMBDA-LIST EXTRACT-SPECIALIZER-NAMES GET-KEYWORD-FROM-ARG ANALYZE-LAMBDA-LIST CHECK-METHOD-LAMBDA-LIST CHECK-ARGUMENT-PRECEDENCE-ORDER ENSURE-METHOD MAKE-INSTANCE-STANDARD-METHOD ADD-DIRECT-METHOD REMOVE-DIRECT-METHOD STD-ADD-METHOD STD-REMOVE-METHOD %FIND-METHOD FAST-CALLABLE-P SLOW-READER-LOOKUP STD-COMPUTE-DISCRIMINATING-FUNCTION SORT-METHODS METHOD-APPLICABLE-P STD-COMPUTE-APPLICABLE-METHODS METHOD-APPLICABLE-USING-CLASSES-P CHECK-APPLICABLE-METHOD-KEYWORD-ARGS COMPUTE-APPLICABLE-KEYWORDS WRAP-EMFUN-FOR-KEYWORD-ARGS-CHECK SLOW-METHOD-LOOKUP SLOW-METHOD-LOOKUP-1 SUB-SPECIALIZER-P STD-METHOD-MORE-SPECIFIC-P PRIMARY-METHOD-P BEFORE-METHOD-P AFTER-METHOD-P AROUND-METHOD-P PROCESS-NEXT-METHOD-LIST STD-COMPUTE-EFFECTIVE-METHOD GENERATE-EMF-LAMBDA COMPUTE-PRIMARY-EMFUN WALK-FORM COMPUTE-METHOD-FUNCTION COMPUTE-METHOD-FAST-FUNCTION MAKE-METHOD-LAMBDA ALLOW-OTHER-KEYS MAKE-INSTANCE-STANDARD-ACCESSOR-METHOD ADD-READER-METHOD ADD-WRITER-METHOD CHECK-DUPLICATE-SLOTS CHECK-DUPLICATE-DEFAULT-INITARGS ENSURE-CLASS-USING-CLASS READER-METHOD-CLASS WRITER-METHOD-CLASS COMPUTE-APPLICABLE-METHODS-USING-CLASSES SLOT-VALUE-USING-CLASS SLOT-EXISTS-P-USING-CLASS SLOT-BOUNDP-USING-CLASS SLOT-MAKUNBOUND-USING-CLASS CALCULATE-ALLOWABLE-INITARGS CHECK-INITARGS MERGE-INITARGS-SETS EXTRACT-LAMBDA-LIST-KEYWORDS AUGMENT-INITARGS-WITH-DEFAULTS STD-SHARED-INITIALIZE COMPUTE-SLOTS COMPUTE-EFFECTIVE-SLOT-DEFINITION COMPUTE-DISCRIMINATING-FUNCTION METHOD-MORE-SPECIFIC-P COMPUTE-EFFECTIVE-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS SPECIALIZER-DIRECT-METHODS ADD-DEPENDENT REMOVE-DEPENDENT UPDATE-DEPENDENT ENSURE-GENERIC-FUNCTION-USING-CLASS %METHOD-GENERIC-FUNCTION %METHOD-FUNCTION)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(DOLIST (SYSTEM::FS (QUOTE ((("clos") CLASS-SLOTS CLASS-DIRECT-SLOTS CLASS-LAYOUT CLASS-DIRECT-SUPERCLASSES CLASS-DIRECT-SUBCLASSES CLASS-DIRECT-METHODS CLASS-PRECEDENCE-LIST CLASS-FINALIZED-P CLASS-DEFAULT-INITARGS CLASS-DIRECT-DEFAULT-INITARGS ADD-DIRECT-SUBCLASS REMOVE-DIRECT-SUBCLASS FIXUP-STANDARD-CLASS-HIERARCHY MAP-DEPENDENTS MAPAPPEND MAPPLIST FUNCALLABLE-STANDARD-INSTANCE-ACCESS CANONICALIZE-DIRECT-SLOTS CANONICALIZE-DIRECT-SLOT MAYBE-NOTE-NAME-DEFINED CANONICALIZE-DEFCLASS-OPTIONS CANONICALIZE-DEFCLASS-OPTION MAKE-INITFUNCTION SLOT-DEFINITION-ALLOCATION SLOT-DEFINITION-INITARGS SLOT-DEFINITION-INITFORM SLOT-DEFINITION-INITFUNCTION SLOT-DEFINITION-NAME SLOT-DEFINITION-READERS SLOT-DEFINITION-WRITERS SLOT-DEFINITION-ALLOCATION-CLASS SLOT-DEFINITION-LOCATION SLOT-DEFINITION-TYPE SLOT-DEFINITION-DOCUMENTATION INIT-SLOT-DEFINITION DIRECT-SLOT-DEFINITION-CLASS MAKE-DIRECT-SLOT-DEFINITION EFFECTIVE-SLOT-DEFINITION-CLASS MAKE-EFFECTIVE-SLOT-DEFINITION COMPUTE-DEFAULT-INITARGS STD-COMPUTE-DEFAULT-INITARGS STD-FINALIZE-INHERITANCE FINALIZE-INHERITANCE STD-COMPUTE-CLASS-PRECEDENCE-LIST TOPOLOGICAL-SORT STD-TIE-BREAKER-RULE COLLECT-SUPERCLASSES* LOCAL-PRECEDENCE-ORDERING STD-COMPUTE-SLOTS STD-COMPUTE-EFFECTIVE-SLOT-DEFINITION FIND-SLOT-DEFINITION SLOT-LOCATION INSTANCE-SLOT-LOCATION %SET-SLOT-VALUE STD-SLOT-MAKUNBOUND STD-SLOT-EXISTS-P INSTANCE-SLOT-P STD-ALLOCATE-INSTANCE ALLOCATE-FUNCALLABLE-INSTANCE CLASS-PROTOTYPE MAYBE-FINALIZE-CLASS-SUBTREE MAKE-INSTANCE-STANDARD-CLASS STD-AFTER-INITIALIZATION-FOR-CLASSES EXPAND-LONG-DEFCOMBIN %MAKE-LONG-METHOD-COMBINATION METHOD-COMBINATION-NAME METHOD-COMBINATION-DOCUMENTATION SHORT-METHOD-COMBINATION-OPERATOR SHORT-METHOD-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT LONG-METHOD-COMBINATION-LAMBDA-LIST LONG-METHOD-COMBINATION-METHOD-GROUP-SPECS LONG-METHOD-COMBINATION-ARGS-LAMBDA-LIST LONG-METHOD-COMBINATION-GENERIC-FUNCTION-SYMBOL LONG-METHOD-COMBINATION-FUNCTION LONG-METHOD-COMBINATION-ARGUMENTS LONG-METHOD-COMBINATION-DECLARATIONS LONG-METHOD-COMBINATION-FORMS EXPAND-SHORT-DEFCOMBIN METHOD-GROUP-P CHECK-VARIABLE-NAME CANONICALIZE-METHOD-GROUP-SPEC EXTRACT-REQUIRED-PART EXTRACT-SPECIFIED-PART EXTRACT-OPTIONAL-PART PARSE-DEFINE-METHOD-COMBINATION-ARGS-LAMBDA-LIST WRAP-WITH-CALL-METHOD-MACRO ASSERT-UNAMBIGUOUS-METHOD-SORTING METHOD-COMBINATION-TYPE-LAMBDA-WITH-ARGS-EMF METHOD-COMBINATION-TYPE-LAMBDA DECLARATIONP LONG-FORM-METHOD-COMBINATION-ARGS DEFINE-LONG-FORM-METHOD-COMBINATION STD-FIND-METHOD-COMBINATION FIND-METHOD-COMBINATION INTERN-EQL-SPECIALIZER EQL-SPECIALIZER-OBJECT STD-METHOD-FUNCTION STD-METHOD-GENERIC-FUNCTION STD-METHOD-SPECIALIZERS STD-METHOD-QUALIFIERS STD-ACCESSOR-METHOD-SLOT-DEFINITION STD-METHOD-FAST-FUNCTION STD-FUNCTION-KEYWORDS METHOD-GENERIC-FUNCTION METHOD-FUNCTION METHOD-SPECIALIZERS GENERIC-FUNCTION-NAME GENERIC-FUNCTION-LAMBDA-LIST GENERIC-FUNCTION-METHODS GENERIC-FUNCTION-METHOD-CLASS GENERIC-FUNCTION-METHOD-COMBINATION GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER CLASSES-TO-EMF-TABLE METHOD-DOCUMENTATION CANONICALIZE-DEFGENERIC-OPTIONS CANONICALIZE-DEFGENERIC-OPTION ARGUMENT-PRECEDENCE-ORDER-INDICES FIND-GENERIC-FUNCTION LAMBDA-LISTS-CONGRUENT-P %DEFGENERIC COLLECT-EQL-SPECIALIZER-OBJECTS FINALIZE-STANDARD-GENERIC-FUNCTION MAKE-INSTANCE-STANDARD-GENERIC-FUNCTION CANONICALIZE-SPECIALIZERS CANONICALIZE-SPECIALIZER PARSE-DEFMETHOD REQUIRED-PORTION EXTRACT-LAMBDA-LIST EXTRACT-SPECIALIZER-NAMES GET-KEYWORD-FROM-ARG ANALYZE-LAMBDA-LIST CHECK-METHOD-LAMBDA-LIST CHECK-ARGUMENT-PRECEDENCE-ORDER ENSURE-METHOD MAKE-INSTANCE-STANDARD-METHOD ADD-DIRECT-METHOD REMOVE-DIRECT-METHOD STD-ADD-METHOD STD-REMOVE-METHOD %FIND-METHOD FAST-CALLABLE-P SLOW-READER-LOOKUP STD-COMPUTE-DISCRIMINATING-FUNCTION SORT-METHODS METHOD-APPLICABLE-P STD-COMPUTE-APPLICABLE-METHODS METHOD-APPLICABLE-USING-CLASSES-P CHECK-APPLICABLE-METHOD-KEYWORD-ARGS COMPUTE-APPLICABLE-KEYWORDS WRAP-EMFUN-FOR-KEYWORD-ARGS-CHECK SLOW-METHOD-LOOKUP SLOW-METHOD-LOOKUP-1 SUB-SPECIALIZER-P STD-METHOD-MORE-SPECIFIC-P PRIMARY-METHOD-P BEFORE-METHOD-P AFTER-METHOD-P AROUND-METHOD-P PROCESS-NEXT-METHOD-LIST STD-COMPUTE-EFFECTIVE-METHOD GENERATE-EMF-LAMBDA COMPUTE-PRIMARY-EMFUN WALK-FORM COMPUTE-METHOD-FUNCTION COMPUTE-METHOD-FAST-FUNCTION MAKE-METHOD-LAMBDA ALLOW-OTHER-KEYS MAKE-INSTANCE-STANDARD-ACCESSOR-METHOD ADD-READER-METHOD ADD-WRITER-METHOD CHECK-DUPLICATE-SLOTS CHECK-DUPLICATE-DEFAULT-INITARGS CANONICALIZE-DIRECT-SUPERCLASSES ENSURE-CLASS ENSURE-CLASS-USING-CLASS READER-METHOD-CLASS WRITER-METHOD-CLASS COMPUTE-APPLICABLE-METHODS-USING-CLASSES SLOT-VALUE-USING-CLASS SLOT-EXISTS-P-USING-CLASS SLOT-BOUNDP-USING-CLASS SLOT-MAKUNBOUND-USING-CLASS CALCULATE-ALLOWABLE-INITARGS CHECK-INITARGS MERGE-INITARGS-SETS EXTRACT-LAMBDA-LIST-KEYWORDS AUGMENT-INITARGS-WITH-DEFAULTS STD-SHARED-INITIALIZE COMPUTE-SLOTS COMPUTE-EFFECTIVE-SLOT-DEFINITION COMPUTE-DISCRIMINATING-FUNCTION METHOD-MORE-SPECIFIC-P COMPUTE-EFFECTIVE-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS SPECIALIZER-DIRECT-METHODS ADD-DEPENDENT REMOVE-DEPENDENT UPDATE-DEPENDENT ENSURE-GENERIC-FUNCTION-USING-CLASS %METHOD-GENERIC-FUNCTION %METHOD-FUNCTION)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) + +;; MACROS + (IN-PACKAGE :MOP) -(DOLIST (SYSTEM::FS (QUOTE ((("clos") DEFINE-CLASS->%CLASS-FORWARDER PUSH-ON-END DEFINE-PRIMORDIAL-CLASS GETK WITH-ARGS-LAMBDA-LIST WITH-METHOD-GROUPS ATOMIC-DEFGENERIC REDEFINE-CLASS-FORWARDER SLOT-DEFINITION-DISPATCH)))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(DOLIST (SYSTEM::FS (QUOTE ((("clos") DEFINE-CLASS->%CLASS-FORWARDER PUSH-ON-END DEFINE-PRIMORDIAL-CLASS WITH-METHOD-GROUPS ATOMIC-DEFGENERIC REDEFINE-CLASS-FORWARDER SLOT-DEFINITION-DISPATCH)))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +;; EXPORTS +(IN-PACKAGE :XP) +(EXPORT (QUOTE (*PRINT-SHARED*))) + +;; FUNCTIONS + (IN-PACKAGE :XP) (DOLIST (SYSTEM::FS (QUOTE ((("pprint-dispatch") MAKE-PPRINT-DISPATCH-TABLE PPRINT-DISPATCH-TABLE-P MAKE-ENTRY ENTRY-P SET-PPRINT-DISPATCH+ PRIORITY-> ADJUST-COUNTS GET-PRINTER FITS SPECIFIER-CATEGORY ALWAYS-TRUE SPECIFIER-FN CONVERT-BODY FUNCTION-CALL-P PPRINT-DISPATCH-PRINT) (("pprint") STRUCTURE-TYPE-P OUTPUT-WIDTH MAKE-XP-STRUCTURE XP-STRUCTURE-P PUSH-BLOCK-STACK POP-BLOCK-STACK PUSH-PREFIX-STACK POP-PREFIX-STACK ENQUEUE INITIALIZE-XP WRITE-CHAR+ WRITE-STRING+ WRITE-CHAR++ FORCE-SOME-OUTPUT WRITE-STRING++ WRITE-STRING+++ PPRINT-TAB+ PPRINT-NEWLINE+ START-BLOCK END-BLOCK PPRINT-INDENT+ ATTEMPT-TO-OUTPUT FLUSH OUTPUT-LINE SETUP-FOR-NEXT-LINE SET-INDENTATION-PREFIX SET-PREFIX SET-SUFFIX REVERSE-STRING-IN-PLACE MAYBE-INITIATE-XP-PRINTING XP-PRINT DO-XP-PRINTING WRITE+ NON-PRETTY-PRINT MAYBE-PRINT-FAST PRINT-FIXNUM PPRINT-POP-CHECK+ CHECK-BLOCK-ABBREVIATION PRETTY-ARRAY PRETTY-VECTOR PRETTY-NON-VECTOR ARRAY-READABLY-PRINTABLE-P FN-CALL ALTERNATIVE-FN-CALL BIND-LIST BLOCK-LIKE DEFUN-LIKE PRINT-FANCY-FN-CALL LET-PRINT COND-PRINT DMM-PRINT DEFSETF-PRINT DO-PRINT FLET-PRINT FUNCTION-PRINT MVB-PRINT MAYBELAB PROG-PRINT TAGBODY-PRINT SETQ-PRINT QUOTE-PRINT UP-PRINT TOKEN-TYPE PRETTY-LOOP OUTPUT-PRETTY-OBJECT)))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) + +;; MACROS + (IN-PACKAGE :XP) (DOLIST (SYSTEM::FS (QUOTE ((("pprint") LP<-BP TP<-BP BP<-LP BP<-TP LP<-TP CHECK-SIZE SECTION-START PREFIX-PTR SUFFIX-PTR NON-BLANK-PREFIX-PTR INITIAL-PREFIX-PTR SECTION-START-LINE QTYPE QKIND QPOS QDEPTH QEND QOFFSET QARG QNEXT MAYBE-TOO-LARGE MISERING? PPRINT-LOGICAL-BLOCK+ PPRINT-POP+)))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) -(IN-PACKAGE :PRECOMPILER) -(DOLIST (SYSTEM::FS (QUOTE ())) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) + +;; FUNCTIONS + + +;; MACROS + +;; EXPORTS +(IN-PACKAGE :PROFILER) +(EXPORT (QUOTE (*HIDDEN-FUNCTIONS*))) + +;; FUNCTIONS + (IN-PACKAGE :PROFILER) (DOLIST (SYSTEM::FS (QUOTE ((("profiler") MAKE-PROFILE-INFO PROFILE-INFO-P LIST-CALLED-OBJECTS OBJECT-NAME OBJECT-COMPILED-FUNCTION-P SHOW-CALL-COUNT SHOW-HOT-COUNT SHOW-CALL-COUNTS SHOW-HOT-COUNTS START-PROFILER)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) + +;; MACROS + (IN-PACKAGE :PROFILER) (DOLIST (SYSTEM::FS (QUOTE ((("profiler") WITH-PROFILING)))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +;; EXPORTS (IN-PACKAGE :JAVA) -(DOLIST (SYSTEM::FS (QUOTE ((("java-collections") JLIST-ADD JLIST-SET JLIST-GET MAKE-JSEQUENCE-LIKE MAKE-JLIST-ITERATOR JSET-ADD) (("java") ADD-URL-TO-CLASSPATH ADD-URLS-TO-CLASSPATH ADD-TO-CLASSPATH JREGISTER-HANDLER JINTERFACE-IMPLEMENTATION JMAKE-INVOCATION-HANDLER JMAKE-PROXY CANONICALIZE-JPROXY-INTERFACES JEQUAL JOBJECT-CLASS JCLASS-SUPERCLASS JCLASS-INTERFACES JCLASS-INTERFACE-P JCLASS-SUPERCLASS-P JCLASS-ARRAY-P JARRAY-COMPONENT-TYPE JARRAY-LENGTH JNEW-ARRAY-FROM-ARRAY JNEW-ARRAY-FROM-LIST JARRAY-FROM-LIST LIST-FROM-JARRAY VECTOR-FROM-JARRAY LIST-FROM-JENUMERATION JCLASS-CONSTRUCTORS JCONSTRUCTOR-PARAMS JCLASS-FIELDS JCLASS-FIELD JFIELD-TYPE JFIELD-NAME JCLASS-METHODS JMETHOD-PARAMS JMETHOD-RETURN-TYPE JMETHOD-DECLARING-CLASS JMETHOD-NAME JINSTANCE-OF-P JMEMBER-STATIC-P JMEMBER-PUBLIC-P JMEMBER-PROTECTED-P JPROPERTY-VALUE JCLASS-ADDITIONAL-SUPERCLASSES ENSURE-JAVA-CLASS JINPUT-STREAM) (("runtime-class") JNEW-RUNTIME-CLASS %JNEW-RUNTIME-CLASS MAKE-ACCESSOR-NAME CANONICALIZE-JAVA-TYPE EMIT-UNBOX-AND-RETURN RUNTIME-CLASS-ADD-METHODS RUNTIME-CLASS-ADD-FIELDS)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(EXPORT (QUOTE (JEQUAL JMETHOD-LET CHAIN ENSURE-JAVA-CLASS DEFINE-JAVA-CLASS JNEW-RUNTIME-CLASS JMEMBER-PROTECTED-P JMEMBER-PUBLIC-P JMEMBER-STATIC-P JINSTANCE-OF-P JMETHOD-NAME JMETHOD-PARAMS JCLASS-METHODS JFIELD-NAME JFIELD-TYPE JCLASS-FIELDS JCLASS-FIELD JCONSTRUCTOR-PARAMS JCLASS-CONSTRUCTORS JARRAY-FROM-LIST JNEW-ARRAY-FROM-LIST JNEW-ARRAY-FROM-ARRAY JARRAY-LENGTH JARRAY-COMPONENT-TYPE JCLASS-ARRAY-P JCLASS-SUPERCLASS-P JCLASS-INTERFACE-P JCLASS-INTERFACES JCLASS-SUPERCLASS JOBJECT-CLASS JPROPERTY-VALUE JMAKE-PROXY JMAKE-INVOCATION-HANDLER JINTERFACE-IMPLEMENTATION JREGISTER-HANDLER))) + +;; FUNCTIONS + +(IN-PACKAGE :JAVA) +(DOLIST (SYSTEM::FS (QUOTE ((("java") ADD-URL-TO-CLASSPATH ADD-URLS-TO-CLASSPATH ADD-TO-CLASSPATH JREGISTER-HANDLER JINTERFACE-IMPLEMENTATION JMAKE-INVOCATION-HANDLER JMAKE-PROXY CANONICALIZE-JPROXY-INTERFACES JEQUAL JOBJECT-CLASS JCLASS-SUPERCLASS JCLASS-INTERFACES JCLASS-INTERFACE-P JCLASS-SUPERCLASS-P JCLASS-ARRAY-P JARRAY-COMPONENT-TYPE JARRAY-LENGTH JNEW-ARRAY-FROM-ARRAY JNEW-ARRAY-FROM-LIST JARRAY-FROM-LIST LIST-FROM-JARRAY VECTOR-FROM-JARRAY LIST-FROM-JENUMERATION JCLASS-CONSTRUCTORS JCONSTRUCTOR-PARAMS JCLASS-FIELDS JCLASS-FIELD JFIELD-TYPE JFIELD-NAME JCLASS-METHODS JMETHOD-PARAMS JMETHOD-RETURN-TYPE JMETHOD-DECLARING-CLASS JMETHOD-NAME JINSTANCE-OF-P JMEMBER-STATIC-P JMEMBER-PUBLIC-P JMEMBER-PROTECTED-P JPROPERTY-VALUE JCLASS-ADDITIONAL-SUPERCLASSES ENSURE-JAVA-CLASS JINPUT-STREAM) (("runtime-class") JNEW-RUNTIME-CLASS %JNEW-RUNTIME-CLASS MAKE-ACCESSOR-NAME CANONICALIZE-JAVA-TYPE EMIT-UNBOX-AND-RETURN RUNTIME-CLASS-ADD-METHODS RUNTIME-CLASS-ADD-FIELDS)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) + +;; MACROS + (IN-PACKAGE :JAVA) (DOLIST (SYSTEM::FS (QUOTE ((("java") CHAIN JMETHOD-LET) (("runtime-class") DEFINE-JAVA-CLASS)))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +;; EXPORTS (IN-PACKAGE :JVM) -(DOLIST (SYSTEM::FS (QUOTE ( (("dump-class") READ-U1 READ-U2 READ-U4 LOOKUP-UTF8 READ-CONSTANT-POOL-ENTRY DUMP-CODE DUMP-CODE-ATTRIBUTE DUMP-EXCEPTIONS READ-ATTRIBUTE READ-INFO DUMP-CLASS) (("jvm-class-file") MAP-PRIMITIVE-TYPE %MAKE-JVM-CLASS-NAME JVM-CLASS-NAME-P MAKE-JVM-CLASS-NAME CLASS-ARRAY INTERNAL-FIELD-TYPE INTERNAL-FIELD-REF DESCRIPTOR DESCRIPTOR-STACK-EFFECT MAKE-POOL POOL-P MAKE-CONSTANT CONSTANT-P MAKE-CONSTANT-CLASS CONSTANT-CLASS-P %MAKE-CONSTANT-MEMBER-REF CONSTANT-MEMBER-REF-P MAKE-CONSTANT-FIELD-REF MAKE-CONSTANT-METHOD-REF MAKE-CONSTANT-INTERFACE-METHOD-REF MAKE-CONSTANT-STRING CONSTANT-STRING-P %MAKE-CONSTANT-FLOAT/INT CONSTANT-FLOAT/INT-P MAKE-CONSTANT-FLOAT MAKE-CONSTANT-INT %MAKE-CONSTANT-DOUBLE/LONG CONSTANT-DOUBLE/LONG-P MAKE-CONSTANT-DOUBLE MAKE-CONSTANT-LONG MAKE-CONSTANT-NAME/TYPE CONSTANT-NAME/TYPE-P MAKE-CONSTANT-UTF8 CONSTANT-UTF8-P POOL-ADD-CLASS POOL-ADD-FIELD-REF POOL-ADD-METHOD-REF POOL-ADD-INTERFACE-METHOD-REF POOL-ADD-STRING POOL-ADD-INT POOL-ADD-FLOAT POOL-ADD-LONG POOL-ADD-DOUBLE POOL-ADD-NAME/TYPE POOL-ADD-UTF8 MAKE-CLASS-FILE CLASS-FILE-P MAKE-CLASS-INTERFACE-FILE CLASS-ADD-FIELD CLASS-FIELD CLASS-ADD-METHOD CLASS-METHODS-BY-NAME CLASS-METHOD CLASS-ADD-ATTRIBUTE CLASS-ADD-SUPERINTERFACE CLASS-ATTRIBUTE FINALIZE-INTERFACES FINALIZE-CLASS-FILE WRITE-U1 WRITE-U2 WRITE-U4 WRITE-S4 WRITE-ASCII WRITE-UTF8 WRITE-CLASS-FILE WRITE-CONSTANTS PRINT-CONSTANT MAP-FLAGS %MAKE-FIELD FIELD-P MAKE-FIELD FIELD-ADD-ATTRIBUTE FIELD-ATTRIBUTE FINALIZE-FIELD WRITE-FIELD %MAKE-JVM-METHOD JVM-METHOD-P MAP-METHOD-NAME MAKE-JVM-METHOD METHOD-ADD-ATTRIBUTE METHOD-ADD-CODE METHOD-ENSURE-CODE METHOD-ATTRIBUTE FINALIZE-METHOD WRITE-METHOD MAKE-ATTRIBUTE ATTRIBUTE-P FINALIZE-ATTRIBUTES WRITE-ATTRIBUTES %MAKE-CODE-ATTRIBUTE CODE-ATTRIBUTE-P CODE-LABEL-OFFSET FINALIZE-CODE-ATTRIBUTE WRITE-CODE-ATTRIBUTE MAKE-CODE-ATTRIBUTE CODE-ADD-ATTRIBUTE CODE-ATTRIBUTE CODE-ADD-EXCEPTION-HANDLER MAKE-EXCEPTION EXCEPTION-P MAKE-CONSTANT-VALUE-ATTRIBUTE CONSTANT-VALUE-ATTRIBUTE-P MAKE-CHECKED-EXCEPTIONS-ATTRIBUTE CHECKED-EXCEPTIONS-ATTRIBUTE-P FINALIZE-CHECKED-EXCEPTIONS WRITE-CHECKED-EXCEPTIONS MAKE-DEPRECATED-ATTRIBUTE DEPRECATED-ATTRIBUTE-P SAVE-CODE-SPECIALS RESTORE-CODE-SPECIALS MAKE-SOURCE-FILE-ATTRIBUTE SOURCE-FILE-ATTRIBUTE-P FINALIZE-SOURCE-FILE WRITE-SOURCE-FILE MAKE-SYNTHETIC-ATTRIBUTE SYNTHETIC-ATTRIBUTE-P MAKE-LINE-NUMBERS-ATTRIBUTE LINE-NUMBERS-ATTRIBUTE-P MAKE-LINE-NUMBER LINE-NUMBER-P FINALIZE-LINE-NUMBERS WRITE-LINE-NUMBERS LINE-NUMBERS-ADD-LINE MAKE-LOCAL-VARIABLES-ATTRIBUTE LOCAL-VARIABLES-ATTRIBUTE-P MAKE-LOCAL-VARIABLE LOCAL-VARIABLE-P FINALIZE-LOCAL-VARIABLES WRITE-LOCAL-VARIABLES MAKE-ANNOTATIONS-ATTRIBUTE ANNOTATIONS-ATTRIBUTE-P MAKE-ANNOTATION ANNOTATION-P MAKE-ANNOTATION-ELEMENT ANNOTATION-ELEMENT-P MAKE-PRIMITIVE-OR-STRING-ANNOTATION-ELEMENT PRIMITIVE-OR-STRING-ANNOTATION-ELEMENT-P MAKE-ENUM-VALUE-ANNOTATION-ELEMENT ENUM-VALUE-ANNOTATION-ELEMENT-P MAKE-ANNOTATION-VALUE-ANNOTATION-ELEMENT ANNOTATION-VALUE-ANNOTATION-ELEMENT-P MAKE-ARRAY-ANNOTATION-ELEMENT ARRAY-ANNOTATION-ELEMENT-P MAKE-RUNTIME-VISIBLE-ANNOTATIONS-ATTRIBUTE RUNTIME-VISIBLE-ANNOTATIONS-ATTRIBUTE-P FINALIZE-ANNOTATIONS FINALIZE-ANNOTATION FINALIZE-ANNOTATION-ELEMENT WRITE-ANNOTATIONS WRITE-ANNOTATION WRITE-ANNOTATION-ELEMENT) (("runtime-class") EMIT-INVOKESPECIAL PARSE-ANNOTATION PARSE-ANNOTATION-ELEMENT)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(EXPORT (QUOTE (DERIVE-COMPILER-TYPE JVM-COMPILE-PACKAGE *CATCH-ERRORS* COMPILE-DEFUN))) + +;; FUNCTIONS + +(IN-PACKAGE :JVM) +(DOLIST (SYSTEM::FS (QUOTE ((("compiler-pass1") GENERATE-INLINE-EXPANSION PARSE-LAMBDA-LIST MATCH-LAMBDA-LIST MATCH-KEYWORD-AND-REST-ARGS EXPAND-FUNCTION-CALL-INLINE PROCESS-DECLARATIONS-FOR-VARS CHECK-NAME P1-BODY P1-DEFAULT P1-LET-VARS P1-LET*-VARS P1-LET/LET* P1-LOCALLY P1-M-V-B P1-BLOCK P1-CATCH P1-THREADS-SYNCHRONIZED-ON P1-UNWIND-PROTECT P1-RETURN-FROM P1-TAGBODY P1-GO SPLIT-DECLS REWRITE-AUX-VARS REWRITE-LAMBDA VALIDATE-FUNCTION-NAME CONSTRUCT-FLET/LABELS-FUNCTION P1-FLET P1-LABELS P1-FUNCALL P1-FUNCTION P1-LAMBDA P1-EVAL-WHEN P1-PROGV P1-QUOTE P1-SETQ P1-THE P1-TRULY-THE P1-THROW REWRITE-FUNCTION-CALL P1-FUNCTION-CALL %FUNCALL P1-VARIABLE-REFERENCE P1 INSTALL-P1-HANDLER INITIALIZE-P1-HANDLERS P1-COMPILAND) (("compiler-pass2") POOL-NAME POOL-NAME-AND-TYPE POOL-CLASS POOL-STRING POOL-FIELD POOL-METHOD POOL-INT POOL-FLOAT POOL-LONG POOL-DOUBLE ADD-EXCEPTION-HANDLER EMIT-PUSH-NIL EMIT-PUSH-NIL-SYMBOL EMIT-PUSH-T EMIT-PUSH-FALSE EMIT-PUSH-TRUE EMIT-PUSH-CONSTANT-INT EMIT-PUSH-CONSTANT-LONG EMIT-PUSH-CONSTANT-FLOAT EMIT-PUSH-CONSTANT-DOUBLE EMIT-DUP EMIT-SWAP EMIT-INVOKESTATIC PRETTY-JAVA-CLASS EMIT-INVOKEVIRTUAL EMIT-INVOKESPECIAL-INIT PRETTY-JAVA-TYPE EMIT-GETSTATIC EMIT-PUTSTATIC EMIT-GETFIELD EMIT-PUTFIELD EMIT-NEW EMIT-ANEWARRAY EMIT-CHECKCAST EMIT-INSTANCEOF TYPE-REPRESENTATION EMIT-UNBOX-BOOLEAN EMIT-UNBOX-CHARACTER CONVERT-REPRESENTATION COMMON-REPRESENTATION MAYBE-INITIALIZE-THREAD-VAR ENSURE-THREAD-VAR-INITIALIZED EMIT-PUSH-CURRENT-THREAD VARIABLE-LOCAL-P EMIT-LOAD-LOCAL-VARIABLE EMIT-PUSH-VARIABLE-NAME GENERATE-INSTANCEOF-TYPE-CHECK-FOR-VARIABLE FIND-TYPE-FOR-TYPE-CHECK GENERATE-TYPE-CHECK-FOR-VARIABLE MAYBE-GENERATE-TYPE-CHECK GENERATE-TYPE-CHECKS-FOR-VARIABLES GENERATE-ARG-COUNT-CHECK MAYBE-GENERATE-INTERRUPT-CHECK SINGLE-VALUED-P EMIT-CLEAR-VALUES MAYBE-EMIT-CLEAR-VALUES COMPILE-FORMS-AND-MAYBE-EMIT-CLEAR-VALUES LOAD-SAVED-OPERANDS SAVE-EXISTING-OPERANDS SAVE-OPERAND COMPILE-OPERAND EMIT-VARIABLE-OPERAND EMIT-REGISTER-OPERAND EMIT-THREAD-OPERAND EMIT-LOAD-EXTERNALIZED-OBJECT-OPERAND EMIT-UNBOX-FIXNUM EMIT-UNBOX-LONG EMIT-UNBOX-FLOAT EMIT-UNBOX-DOUBLE FIX-BOXING EMIT-MOVE-FROM-STACK EMIT-PUSH-REGISTER EMIT-INVOKE-METHOD CHECK-NUMBER-OF-ARGS CHECK-ARG-COUNT CHECK-MIN-ARGS EMIT-CONSTRUCTOR-LAMBDA-NAME EMIT-CONSTRUCTOR-LAMBDA-LIST EMIT-READ-FROM-STRING MAKE-CONSTRUCTOR MAKE-STATIC-INITIALIZER FINISH-CLASS DECLARE-FIELD SANITIZE SERIALIZE-INTEGER SERIALIZE-CHARACTER SERIALIZE-FLOAT SERIALIZE-DOUBLE SERIALIZE-STRING SERIALIZE-PACKAGE COMPILAND-EXTERNAL-CONSTANT-RESOURCE-NAME SERIALIZE-OBJECT SERIALIZE-SYMBOL EMIT-LOAD-EXTERNALIZED-OBJECT DECLARE-FUNCTION DECLARE-SETF-FUNCTION LOCAL-FUNCTION-CLASS-AND-FIELD DECLARE-LOCAL-FUNCTION DECLARE-OBJECT-AS-STRING DECLARE-LOAD-TIME-VALUE DECLARE-OBJECT COMPILE-CONSTANT INITIALIZE-UNARY-OPERATORS INSTALL-P2-HANDLER DEFINE-PREDICATE P2-PREDICATE COMPILE-FUNCTION-CALL-1 INITIALIZE-BINARY-OPERATORS COMPILE-BINARY-OPERATION COMPILE-FUNCTION-CALL-2 FIXNUM-OR-UNBOXED-VARIABLE-P EMIT-PUSH-INT EMIT-PUSH-LONG P2-EQ/NEQ EMIT-IFNE-FOR-EQL P2-EQL P2-MEMQ P2-MEMQL P2-GENSYM P2-GET P2-GETF P2-GETHASH P2-PUTHASH INLINE-OK PROCESS-ARGS EMIT-CALL-EXECUTE EMIT-CALL-THREAD-EXECUTE COMPILE-FUNCTION-CALL COMPILE-CALL P2-FUNCALL DUPLICATE-CLOSURE-ARRAY EMIT-LOAD-LOCAL-FUNCTION COMPILE-LOCAL-FUNCTION-CALL EMIT-NUMERIC-COMPARISON P2-NUMERIC-COMPARISON P2-TEST-HANDLER INITIALIZE-P2-TEST-HANDLERS NEGATE-JUMP-CONDITION EMIT-TEST-JUMP P2-TEST-PREDICATE P2-TEST-INSTANCEOF-PREDICATE P2-TEST-BIT-VECTOR-P P2-TEST-CHARACTERP P2-TEST-CONSTANTP P2-TEST-ENDP P2-TEST-EVENP P2-TEST-ODDP P2-TEST-FLOATP P2-TEST-INTEGERP P2-TEST-LISTP P2-TEST-MINUSP P2-TEST-PLUSP P2-TEST-ZEROP P2-TEST-NUMBERP P2-TEST-PACKAGEP P2-TEST-RATIONALP P2-TEST-REALP P2-TEST-SPECIAL-OPERATOR-P P2-TEST-SPECIAL-VARIABLE-P P2-TEST-SYMBOLP P2-TEST-CONSP P2-TEST-ATOM P2-TEST-FIXNUMP P2-TEST-STRINGP P2-TEST-VECTORP P2-TEST-SIMPLE-VECTOR-P COMPILE-TEST-FORM P2-TEST-NOT/NULL P2-TEST-CHAR= P2-TEST-EQ P2-TEST-OR P2-TEST-AND P2-TEST-NEQ P2-TEST-EQL P2-TEST-EQUALITY P2-TEST-SIMPLE-TYPEP P2-TEST-MEMQ P2-TEST-MEMQL P2-TEST-/= P2-TEST-NUMERIC-COMPARISON P2-IF COMPILE-MULTIPLE-VALUE-LIST COMPILE-MULTIPLE-VALUE-PROG1 COMPILE-MULTIPLE-VALUE-CALL UNUSED-VARIABLE CHECK-FOR-UNUSED-VARIABLES EMIT-NEW-CLOSURE-BINDING COMPILE-BINDING COMPILE-PROGN-BODY RESTORE-DYNAMIC-ENVIRONMENT SAVE-DYNAMIC-ENVIRONMENT P2-M-V-B-NODE PROPAGATE-VARS DERIVE-VARIABLE-REPRESENTATION ALLOCATE-VARIABLE-REGISTER EMIT-MOVE-TO-VARIABLE EMIT-PUSH-VARIABLE P2-LET-BINDINGS P2-LET*-BINDINGS P2-LET/LET*-NODE P2-LOCALLY-NODE P2-TAGBODY-NODE P2-GO P2-ATOM P2-INSTANCEOF-PREDICATE P2-BIT-VECTOR-P P2-CHARACTERP P2-CONSP P2-FIXNUMP P2-PACKAGEP P2-READTABLEP P2-SIMPLE-VECTOR-P P2-STRINGP P2-SYMBOLP P2-VECTORP P2-COERCE-TO-FUNCTION P2-BLOCK-NODE P2-RETURN-FROM EMIT-CAR/CDR P2-CAR P2-CDR P2-CONS COMPILE-PROGN P2-EVAL-WHEN P2-LOAD-TIME-VALUE P2-PROGV-NODE P2-QUOTE P2-RPLACD P2-SET-CAR/CDR COMPILE-DECLARE COMPILE-LOCAL-FUNCTION P2-FLET-NODE P2-LABELS-NODE P2-LAMBDA P2-FUNCTION P2-ASH P2-LOGAND P2-LOGIOR P2-LOGXOR P2-LOGNOT P2-%LDB P2-MOD P2-ZEROP P2-FIND-CLASS P2-VECTOR-PUSH-EXTEND P2-STD-SLOT-VALUE P2-SET-STD-SLOT-VALUE P2-STREAM-ELEMENT-TYPE P2-WRITE-8-BITS P2-READ-LINE DERIVE-TYPE-AREF DERIVE-TYPE-FIXNUMP DERIVE-TYPE-SETQ DERIVE-TYPE-LOGIOR/LOGXOR DERIVE-TYPE-LOGAND DERIVE-TYPE-LOGNOT DERIVE-TYPE-MOD DERIVE-TYPE-COERCE DERIVE-TYPE-COPY-SEQ DERIVE-TYPE-INTEGER-LENGTH DERIVE-TYPE-%LDB DERIVE-INTEGER-TYPE DERIVE-TYPE-NUMERIC-OP DERIVE-COMPILER-TYPES DERIVE-TYPE-MINUS DERIVE-TYPE-PLUS DERIVE-TYPE-TIMES DERIVE-TYPE-MAX DERIVE-TYPE-MIN DERIVE-TYPE-READ-CHAR DERIVE-TYPE-ASH DERIVE-TYPE DERIVE-COMPILER-TYPE P2-DELETE P2-LENGTH CONS-FOR-LIST/LIST* P2-LIST P2-LIST* COMPILE-NTH P2-TIMES P2-MIN/MAX P2-PLUS P2-MINUS P2-CHAR/SCHAR P2-SET-CHAR/SCHAR P2-SVREF P2-SVSET P2-TRUNCATE P2-ELT P2-AREF P2-ASET P2-STRUCTURE-REF P2-STRUCTURE-SET P2-NOT/NULL P2-NTHCDR P2-AND P2-OR P2-VALUES COMPILE-SPECIAL-REFERENCE COMPILE-VAR-REF P2-SET P2-SETQ P2-SXHASH P2-SYMBOL-NAME P2-SYMBOL-PACKAGE P2-SYMBOL-VALUE GENERATE-INSTANCEOF-TYPE-CHECK-FOR-VALUE GENERATE-TYPE-CHECK-FOR-VALUE P2-THE P2-TRULY-THE P2-CHAR-CODE P2-JAVA-JCLASS P2-JAVA-JCONSTRUCTOR P2-JAVA-JMETHOD P2-CHAR= P2-THREADS-SYNCHRONIZED-ON P2-CATCH-NODE P2-THROW P2-UNWIND-PROTECT-NODE COMPILE-FORM P2-COMPILAND-PROCESS-TYPE-DECLARATIONS P2-COMPILAND-UNBOX-VARIABLE ASSIGN-FIELD-NAME P2-COMPILAND COMPILE-TO-JVM-CLASS P2-WITH-INLINE-CODE COMPILE-1 MAKE-COMPILER-ERROR-FORM COMPILE-DEFUN NOTE-ERROR-CONTEXT HANDLE-WARNING HANDLE-COMPILER-ERROR %WITH-COMPILATION-UNIT %JVM-COMPILE JVM-COMPILE JVM-COMPILE-PACKAGE INITIALIZE-P2-HANDLERS) (("dump-class") READ-U1 READ-U2 READ-U4 LOOKUP-UTF8 READ-CONSTANT-POOL-ENTRY DUMP-CODE DUMP-CODE-ATTRIBUTE DUMP-EXCEPTIONS READ-ATTRIBUTE READ-INFO DUMP-CLASS) (("jvm-class-file") MAP-PRIMITIVE-TYPE PRETTY-CLASS PRETTY-TYPE %MAKE-JVM-CLASS-NAME JVM-CLASS-NAME-P MAKE-JVM-CLASS-NAME CLASS-ARRAY INTERNAL-FIELD-TYPE INTERNAL-FIELD-REF DESCRIPTOR DESCRIPTOR-STACK-EFFECT MAKE-POOL POOL-P MATCHING-INDEX-P FIND-POOL-ENTRY MAKE-CONSTANT CONSTANT-P PRINT-POOL-CONSTANT MAKE-CONSTANT-CLASS CONSTANT-CLASS-P %MAKE-CONSTANT-MEMBER-REF CONSTANT-MEMBER-REF-P MAKE-CONSTANT-FIELD-REF MAKE-CONSTANT-METHOD-REF MAKE-CONSTANT-INTERFACE-METHOD-REF MAKE-CONSTANT-STRING CONSTANT-STRING-P %MAKE-CONSTANT-FLOAT/INT CONSTANT-FLOAT/INT-P MAKE-CONSTANT-FLOAT MAKE-CONSTANT-INT %MAKE-CONSTANT-DOUBLE/LONG CONSTANT-DOUBLE/LONG-P MAKE-CONSTANT-DOUBLE MAKE-CONSTANT-LONG MAKE-CONSTANT-NAME/TYPE CONSTANT-NAME/TYPE-P PARSE-DESCRIPTOR MAKE-CONSTANT-UTF8 CONSTANT-UTF8-P POOL-ADD-CLASS POOL-ADD-FIELD-REF POOL-ADD-METHOD-REF POOL-ADD-INTERFACE-METHOD-REF POOL-ADD-STRING POOL-ADD-INT POOL-ADD-FLOAT POOL-ADD-LONG POOL-ADD-DOUBLE POOL-ADD-NAME/TYPE POOL-ADD-UTF8 MAKE-CLASS-FILE CLASS-FILE-P MAKE-CLASS-INTERFACE-FILE CLASS-ADD-FIELD CLASS-FIELD CLASS-ADD-METHOD CLASS-METHODS-BY-NAME CLASS-METHOD CLASS-REMOVE-METHOD CLASS-ADD-ATTRIBUTE CLASS-ADD-SUPERINTERFACE CLASS-ATTRIBUTE FINALIZE-INTERFACES FINALIZE-CLASS-FILE WRITE-U1 WRITE-U2 WRITE-U4 WRITE-S4 WRITE-ASCII WRITE-UTF8 WRITE-CLASS-FILE WRITE-CONSTANTS PRINT-ENTRY MAP-FLAGS %MAKE-FIELD FIELD-P MAKE-FIELD FIELD-ADD-ATTRIBUTE FIELD-ATTRIBUTE FINALIZE-FIELD WRITE-FIELD %MAKE-JVM-METHOD JVM-METHOD-P MAP-METHOD-NAME MAKE-JVM-METHOD METHOD-ADD-ATTRIBUTE METHOD-ADD-CODE METHOD-ENSURE-CODE METHOD-ATTRIBUTE FINALIZE-METHOD WRITE-METHOD MAKE-ATTRIBUTE ATTRIBUTE-P FINALIZE-ATTRIBUTES WRITE-ATTRIBUTES %MAKE-CODE-ATTRIBUTE CODE-ATTRIBUTE-P CODE-LABEL-OFFSET FINALIZE-CODE-ATTRIBUTE WRITE-CODE-ATTRIBUTE MAKE-CODE-ATTRIBUTE CODE-ADD-ATTRIBUTE CODE-ATTRIBUTE CODE-ADD-EXCEPTION-HANDLER MAKE-EXCEPTION EXCEPTION-P MAKE-CONSTANT-VALUE-ATTRIBUTE CONSTANT-VALUE-ATTRIBUTE-P MAKE-CHECKED-EXCEPTIONS-ATTRIBUTE CHECKED-EXCEPTIONS-ATTRIBUTE-P FINALIZE-CHECKED-EXCEPTIONS WRITE-CHECKED-EXCEPTIONS MAKE-DEPRECATED-ATTRIBUTE DEPRECATED-ATTRIBUTE-P SAVE-CODE-SPECIALS RESTORE-CODE-SPECIALS MAKE-SOURCE-FILE-ATTRIBUTE SOURCE-FILE-ATTRIBUTE-P FINALIZE-SOURCE-FILE WRITE-SOURCE-FILE MAKE-SYNTHETIC-ATTRIBUTE SYNTHETIC-ATTRIBUTE-P MAKE-LINE-NUMBERS-ATTRIBUTE LINE-NUMBERS-ATTRIBUTE-P MAKE-LINE-NUMBER LINE-NUMBER-P FINALIZE-LINE-NUMBERS WRITE-LINE-NUMBERS LINE-NUMBERS-ADD-LINE MAKE-LOCAL-VARIABLES-ATTRIBUTE LOCAL-VARIABLES-ATTRIBUTE-P MAKE-LOCAL-VARIABLE LOCAL-VARIABLE-P FINALIZE-LOCAL-VARIABLES WRITE-LOCAL-VARIABLES MAKE-ANNOTATIONS-ATTRIBUTE ANNOTATIONS-ATTRIBUTE-P MAKE-ANNOTATION ANNOTATION-P MAKE-ANNOTATION-ELEMENT ANNOTATION-ELEMENT-P MAKE-PRIMITIVE-OR-STRING-ANNOTATION-ELEMENT PRIMITIVE-OR-STRING-ANNOTATION-ELEMENT-P MAKE-ENUM-VALUE-ANNOTATION-ELEMENT ENUM-VALUE-ANNOTATION-ELEMENT-P MAKE-ANNOTATION-VALUE-ANNOTATION-ELEMENT ANNOTATION-VALUE-ANNOTATION-ELEMENT-P MAKE-ARRAY-ANNOTATION-ELEMENT ARRAY-ANNOTATION-ELEMENT-P MAKE-RUNTIME-VISIBLE-ANNOTATIONS-ATTRIBUTE RUNTIME-VISIBLE-ANNOTATIONS-ATTRIBUTE-P FINALIZE-ANNOTATIONS FINALIZE-ANNOTATION FINALIZE-ANNOTATION-ELEMENT WRITE-ANNOTATIONS WRITE-ANNOTATION WRITE-ANNOTATION-ELEMENT) (("jvm-instructions") U2 S1 S2 MAKE-JVM-OPCODE JVM-OPCODE-P %DEFINE-OPCODE OPCODE-NAME OPCODE-NUMBER OPCODE-SIZE OPCODE-STACK-EFFECT OPCODE-ARGS-SPEC %MAKE-INSTRUCTION INSTRUCTION-P MAKE-INSTRUCTION PRINT-INSTRUCTION INSTRUCTION-LABEL INST %%EMIT %EMIT LABEL ALOAD ASTORE BRANCH-P UNCONDITIONAL-CONTROL-TRANSFER-P LABEL-P FORMAT-INSTRUCTION-ARGS PRINT-CODE PRINT-CODE2 EXPAND-VIRTUAL-INSTRUCTIONS UNSUPPORTED-OPCODE INITIALIZE-RESOLVERS LOAD/STORE-RESOLVER RESOLVE-INSTRUCTION RESOLVE-INSTRUCTIONS ANALYZE-STACK-PATH ANALYZE-STACK ANALYZE-LOCALS DELETE-UNUSED-LABELS DELETE-UNREACHABLE-CODE LABEL-TARGET-INSTRUCTIONS OPTIMIZE-JUMPS OPTIMIZE-INSTRUCTION-SEQUENCES OPTIMIZE-CODE CODE-BYTES FINALIZE-CODE) (("jvm") INVOKE-CALLBACKS %MAKE-ABCL-CLASS-FILE ABCL-CLASS-FILE-P CLASS-NAME-FROM-FILESPEC MAKE-UNIQUE-CLASS-NAME MAKE-ABCL-CLASS-FILE MAKE-COMPILAND COMPILAND-P COMPILAND-SINGLE-VALUED-P DUMP-1-VARIABLE DUMP-VARIABLES MAKE-VARIABLE VARIABLE-P MAKE-VAR-REF VAR-REF-P UNBOXED-FIXNUM-VARIABLE FIND-VARIABLE FIND-VISIBLE-VARIABLE REPRESENTATION-SIZE ALLOCATE-REGISTER MAKE-LOCAL-FUNCTION LOCAL-FUNCTION-P FIND-LOCAL-FUNCTION MAKE-NODE NODE-P ADD-NODE-CHILD MAKE-CONTROL-TRANSFERRING-NODE CONTROL-TRANSFERRING-NODE-P %MAKE-TAGBODY-NODE TAGBODY-NODE-P MAKE-TAGBODY-NODE %MAKE-CATCH-NODE CATCH-NODE-P MAKE-CATCH-NODE %MAKE-BLOCK-NODE BLOCK-NODE-P MAKE-BLOCK-NODE %MAKE-JUMP-NODE JUMP-NODE-P MAKE-JUMP-NODE MAKE-BINDING-NODE BINDING-NODE-P %MAKE-LET/LET*-NODE LET/LET*-NODE-P MAKE-LET/LET*-NODE %MAKE-FLET-NODE FLET-NODE-P MAKE-FLET-NODE %MAKE-LABELS-NODE LABELS-NODE-P MAKE-LABELS-NODE %MAKE-M-V-B-NODE M-V-B-NODE-P MAKE-M-V-B-NODE %MAKE-PROGV-NODE PROGV-NODE-P MAKE-PROGV-NODE %MAKE-LOCALLY-NODE LOCALLY-NODE-P MAKE-LOCALLY-NODE %MAKE-PROTECTED-NODE PROTECTED-NODE-P MAKE-PROTECTED-NODE %MAKE-UNWIND-PROTECT-NODE UNWIND-PROTECT-NODE-P MAKE-UNWIND-PROTECT-NODE %MAKE-SYNCHRONIZED-NODE SYNCHRONIZED-NODE-P MAKE-SYNCHRONIZED-NODE FIND-BLOCK %FIND-ENCLOSED-BLOCKS FIND-ENCLOSED-BLOCKS SOME-NESTED-BLOCK NODE-CONSTANT-P BLOCK-REQUIRES-NON-LOCAL-EXIT-P NODE-OPSTACK-UNSAFE-P BLOCK-CREATES-RUNTIME-BINDINGS-P ENCLOSED-BY-RUNTIME-BINDINGS-CREATING-BLOCK-P ENCLOSED-BY-PROTECTED-BLOCK-P ENCLOSED-BY-ENVIRONMENT-SETTING-BLOCK-P ENVIRONMENT-REGISTER-TO-RESTORE MAKE-TAG TAG-P FIND-TAG PROCESS-IGNORE/IGNORABLE FINALIZE-GENERIC-FUNCTIONS) (("runtime-class") EMIT-INVOKESPECIAL PARSE-ANNOTATION PARSE-ANNOTATION-ELEMENT)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) + +;; MACROS + (IN-PACKAGE :JVM) -(DOLIST (SYSTEM::FS (QUOTE ( (("dump-class") OUT) (("jvm") DEFINE-OPCODE EMIT DEFINE-RESOLVER) ))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(DOLIST (SYSTEM::FS (QUOTE ((("compiler-pass1") PUSH-ARGUMENT-BINDING P1-LET/LET*-VARS) (("compiler-pass2") WITH-OPERAND-ACCUMULATION ACCUMULATE-OPERAND DECLARE-WITH-HASHTABLE DEFINE-INLINED-FUNCTION P2-TEST-INTEGER-PREDICATE DEFINE-DERIVE-TYPE-HANDLER DEFINE-INT-BOUNDS-DERIVATION WITH-OPEN-CLASS-FILE WITH-FILE-COMPILATION) (("dump-class") OUT) (("jvm-class-file") DEFINE-CLASS-NAME WITH-CODE-TO-METHOD) (("jvm-instructions") DEFINE-OPCODE EMIT DEFINE-RESOLVER) (("jvm") DFORMAT WITH-SAVED-COMPILER-POLICY WITH-CLASS-FILE)))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +;; EXPORTS (IN-PACKAGE :EXTENSIONS) -(DOLIST (SYSTEM::FS (QUOTE ((("collect") COLLECT-NORMAL-EXPANDER COLLECT-LIST-EXPANDER) (("compile-file") COMPILE-FILE-IF-NEEDED) (("compile-system") GROVEL-JAVA-DEFINITIONS COMPILE-SYSTEM) (("debug") SHOW-RESTARTS) (("describe-compiler-policy") DESCRIBE-COMPILER-POLICY) (("featurep") FEATUREP) (("gui") INIT-GUI MAKE-DIALOG-PROMPT-STREAM %MAKE-DIALOG-PROMPT-STREAM) (("pathnames") URL-PATHNAME-SCHEME SET-URL-PATHNAME-SCHEME URL-PATHNAME-AUTHORITY SET-URL-PATHNAME-AUTHORITY URL-PATHNAME-QUERY SET-URL-PATHNAME-QUERY URL-PATHNAME-FRAGMENT SET-URL-PATHNAME-FRAGMENT) (("pprint") CHARPOS) (("run-program") RUN-PROGRAM PROCESS-P PROCESS-ALIVE-P PROCESS-WAIT PROCESS-EXIT-CODE PROCESS-KILL) (("run-shell-command") RUN-SHELL-COMMAND) (("search") SIMPLE-SEARCH) (("socket") GET-SOCKET-STREAM MAKE-SOCKET MAKE-SERVER-SOCKET SOCKET-ACCEPT SOCKET-CLOSE SERVER-SOCKET-CLOSE SOCKET-LOCAL-ADDRESS SOCKET-PEER-ADDRESS SOCKET-LOCAL-PORT SOCKET-PEER-PORT)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(EXPORT (QUOTE (COLLECT SHOW-RESTARTS *DEBUG-LEVEL* *DEBUG-CONDITION* FEATUREP URL-PATHNAME-FRAGMENT URL-PATHNAME-QUERY URL-PATHNAME-AUTHORITY URL-PATHNAME-SCHEME SOCKET-PEER-ADDRESS SOCKET-LOCAL-ADDRESS SOCKET-LOCAL-PORT SOCKET-PEER-PORT GET-SOCKET-STREAM SOCKET-CLOSE SOCKET-ACCEPT SERVER-SOCKET-CLOSE MAKE-SERVER-SOCKET MAKE-SOCKET))) + +;; FUNCTIONS + +(IN-PACKAGE :EXTENSIONS) +(DOLIST (SYSTEM::FS (QUOTE ((("collect") COLLECT-NORMAL-EXPANDER COLLECT-LIST-EXPANDER) (("compile-file") COMPILE-FILE-IF-NEEDED) (("compile-system") GROVEL-JAVA-DEFINITIONS COMPILE-SYSTEM) (("debug") SHOW-RESTARTS) (("describe-compiler-policy") DESCRIBE-COMPILER-POLICY) (("featurep") FEATUREP) (("gui") INIT-GUI MAKE-DIALOG-PROMPT-STREAM %MAKE-DIALOG-PROMPT-STREAM) (("pathnames") URL-PATHNAME-SCHEME SET-URL-PATHNAME-SCHEME URL-PATHNAME-AUTHORITY SET-URL-PATHNAME-AUTHORITY URL-PATHNAME-QUERY SET-URL-PATHNAME-QUERY URL-PATHNAME-FRAGMENT SET-URL-PATHNAME-FRAGMENT) (("pprint") CHARPOS) (("run-program") RUN-PROGRAM PROCESS-P PROCESS-ALIVE-P PROCESS-WAIT PROCESS-EXIT-CODE PROCESS-KILL) (("run-shell-command") RUN-SHELL-COMMAND) (("search") SIMPLE-SEARCH) (("socket") GET-SOCKET-STREAM MAKE-SOCKET MAKE-SERVER-SOCKET SOCKET-ACCEPT SOCKET-CLOSE SERVER-SOCKET-CLOSE %SOCKET-ADDRESS %SOCKET-PORT SOCKET-LOCAL-ADDRESS SOCKET-PEER-ADDRESS SOCKET-LOCAL-PORT SOCKET-PEER-PORT)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) + +;; MACROS + (IN-PACKAGE :EXTENSIONS) -(DOLIST (SYSTEM::FS (QUOTE ((("aver") AVER) (("collect") COLLECT) ))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(DOLIST (SYSTEM::FS (QUOTE ((("aver") AVER) (("collect") COLLECT)))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +;; EXPORTS +(IN-PACKAGE :THREADS) +(EXPORT (QUOTE (RELEASE-MUTEX GET-MUTEX MAKE-MUTEX MAILBOX-PEEK MAILBOX-READ MAILBOX-EMPTY-P MAILBOX-SEND MAKE-MAILBOX WITH-MUTEX WITH-THREAD-LOCK MAKE-THREAD-LOCK))) + +;; FUNCTIONS + (IN-PACKAGE :THREADS) (DOLIST (SYSTEM::FS (QUOTE ((("threads") THREAD-FUNCTION-WRAPPER MAKE-MAILBOX MAILBOX-P MAILBOX-SEND MAILBOX-EMPTY-P MAILBOX-READ MAILBOX-PEEK MAKE-MUTEX MUTEX-P GET-MUTEX RELEASE-MUTEX MAKE-THREAD-LOCK)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) + +;; MACROS + (IN-PACKAGE :THREADS) (DOLIST (SYSTEM::FS (QUOTE ((("threads") WITH-MUTEX WITH-THREAD-LOCK)))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) + +;; FUNCTIONS + +(IN-PACKAGE :TOP-LEVEL) +(DOLIST (SYSTEM::FS (QUOTE ((("top-level") PROMPT-PACKAGE-NAME REPL-PROMPT-FUN PEEK-CHAR-NON-WHITESPACE APROPOS-COMMAND CONTINUE-COMMAND DESCRIBE-COMMAND ERROR-COMMAND PRINT-FRAME BACKTRACE-COMMAND FRAME-COMMAND INSPECT-COMMAND ISTEP-COMMAND MACROEXPAND-COMMAND PACKAGE-COMMAND RESET-COMMAND EXIT-COMMAND CD-COMMAND LS-COMMAND TOKENIZE LD-COMMAND CF-COMMAND CLOAD-COMMAND RQ-COMMAND PWD-COMMAND TRACE-COMMAND UNTRACE-COMMAND PAD %HELP-COMMAND HELP-COMMAND ENTRY-NAME ENTRY-ABBREVIATION ENTRY-COMMAND ENTRY-HELP FIND-COMMAND PROCESS-CMD READ-CMD REPL-READ-FORM-FUN REPL TOP-LEVEL-LOOP)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) + +;; MACROS + +;; EXPORTS +(IN-PACKAGE :SYSTEM) +(EXPORT (QUOTE (*COMPILER-DIAGNOSTIC* COMPILER-UNSUPPORTED INTERNAL-COMPILER-ERROR COMPILER-ERROR COMPILER-WARN COMPILER-STYLE-WARN *COMPILER-ERROR-CONTEXT* COMPILER-MACROEXPAND DEFKNOWN FUNCTION-RESULT-TYPE COMPILER-SUBTYPEP MAKE-COMPILER-TYPE JAVA-LONG-TYPE-P INTEGER-CONSTANT-VALUE FIXNUM-CONSTANT-VALUE FIXNUM-TYPE-P +INTEGER-TYPE+ +FIXNUM-TYPE+ MAKE-INTEGER-TYPE %MAKE-INTEGER-TYPE INTEGER-TYPE-P INTEGER-TYPE-HIGH INTEGER-TYPE-LOW +FALSE-TYPE+ +TRUE-TYPE+ COMPILER-DEFSTRUCT PARSE-BODY DUMP-UNINTERNED-SYMBOL-INDEX DUMP-FORM LOOKUP-KNOWN-SYMBOL STANDARD-INSTANCE-ACCESS SLOT-DEFINITION FORWARD-REFERENCED-CLASS LOGICAL-HOST-P *INLINE-DECLARATIONS* FTYPE-RESULT-TYPE PROCLAIMED-FTYPE PROCLAIMED-TYPE CHECK-DECLARATION-TYPE EXPAND-SOURCE-TRANSFORM DEFINE-SOURCE-TRANSFORM SOURCE-TRANSFORM UNTRACED-FUNCTION))) + +;; FUNCTIONS + (IN-PACKAGE :SYSTEM) -(DOLIST (FS (QUOTE ((("abcl-contrib") FIND-SYSTEM-JAR FIND-CONTRIB) (("assert") ASSERT-ERROR ASSERT-PROMPT) (("aver") %FAILED-AVER) (("bit-array-ops") BIT-ARRAY-SAME-DIMENSIONS-P REQUIRE-SAME-DIMENSIONS PICK-RESULT-ARRAY) (("case") LIST-OF-LENGTH-AT-LEAST-P CASE-BODY-ERROR CASE-BODY-AUX CASE-BODY) (("check-type") CHECK-TYPE-ERROR) (("clos") %DEFGENERIC CANONICALIZE-DIRECT-SUPERCLASSES ENSURE-CLASS) (("coerce") COERCE-LIST-TO-VECTOR COPY-STRING COERCE-ERROR COERCE-OBJECT-TO-AND-TYPE) (("compile-file-pathname") CFP-OUTPUT-FILE-DEFAULT) (("compile-file") BASE-CLASSNAME FASL-LOADER-CLASSNAME COMPUTE-CLASSFILE-NAME SANITIZE-CLASS-NAME NEXT-CLASSFILE-NAME DUMMY VERIFY-LOAD NOTE-TOPLEVEL-FORM OUTPUT-FORM FINALIZE-FASL-OUTPUT SIMPLE-TOPLEVEL-FORM-P CONVERT-TOPLEVEL-FORM PROCESS-PROGN PRECOMPILE-TOPLEVEL-FORM PROCESS-TOPLEVEL-MACROLET PROCESS-TOPLEVEL-DEFCONSTANT PROCESS-TOPLEVEL-QUOTE PROCESS-TOPLEVEL-IMPORT PROCESS-TOPLEVEL-MOP.ENSURE-METHOD PROCESS-TOPLEVEL-DEFVAR/DEFPARAMETER PROCESS-TOPLEVEL-DEFPACKAGE/IN-PACKAGE PROCESS-TOPLEVEL-DECLARE PROCESS-TOPLEVEL-PROGN PROCESS-TOPLEVEL-DEFTYPE PROCESS-TOPLEVEL-EVAL-WHEN PROCESS-TOPLEVEL-DEFMETHOD/DEFGENERIC PROCESS-TOPLEVEL-LOCALLY PROCESS-TOPLEVEL-DEFMACRO PROCESS-TOPLEVEL-DEFUN INSTALL-TOPLEVEL-HANDLER PROCESS-TOPLEVEL-FORM POPULATE-ZIP-FASL WRITE-FASL-PROLOGUE) (("compile-system") CHECK-LISP-HOME GROVEL-JAVA-DEFINITIONS-IN-FILE PACKAGES-FROM-COMBOS REMOVE-MULTI-COMBO-SYMBOLS SET-EQUAL COMBOS-TO-SYMBOL-FILESETS COMBOS-TO-FILESET-SYMBOLS WRITE-AUTOLOADER WRITE-PACKAGE-FILESETS LOAD-COMBOS GENERATE-AUTOLOADS %COMPILE-SYSTEM CREATE-SYSTEM-LOGICAL-TRANSLATIONS) (("compiler-error") COMPILER-STYLE-WARN COMPILER-WARN COMPILER-ERROR INTERNAL-COMPILER-ERROR COMPILER-UNSUPPORTED) (("compiler-macro") COMPILER-MACROEXPAND-1 COMPILER-MACROEXPAND) (("compiler-types") MAKE-CONSTANT-TYPE CONSTANT-TYPE-P %MAKE-INTEGER-TYPE INTEGER-TYPE-P MAKE-INTEGER-TYPE FIXNUM-TYPE-P FIXNUM-CONSTANT-VALUE INTEGER-CONSTANT-VALUE JAVA-LONG-TYPE-P MAKE-UNION-TYPE MAKE-COMPILER-TYPE INTEGER-TYPE-SUBTYPEP COMPILER-SUBTYPEP FUNCTION-RESULT-TYPE SET-FUNCTION-RESULT-TYPE %DEFKNOWN) (("concatenate") CONCATENATE-TO-STRING) (("debug") INTERNAL-DEBUG DEBUG-LOOP INVOKE-DEBUGGER-REPORT-CONDITION RUN-HOOK BACKTRACE-AS-LIST) (("define-symbol-macro") %DEFINE-SYMBOL-MACRO) (("defpackage") DESIGNATED-PACKAGE-NAME STRINGIFY-NAMES CHECK-DISJOINT) (("defsetf") %DEFSETF) (("defstruct") MAKE-DEFSTRUCT-DESCRIPTION MAKE-DEFSTRUCT-SLOT-DESCRIPTION KEYWORDIFY DEFINE-KEYWORD-CONSTRUCTOR FIND-DSD GET-SLOT DEFINE-BOA-CONSTRUCTOR DEFAULT-CONSTRUCTOR-NAME DEFINE-CONSTRUCTORS NAME-INDEX DEFINE-PREDICATE MAKE-LIST-READER MAKE-VECTOR-READER MAKE-STRUCTURE-READER DEFINE-READER MAKE-LIST-WRITER MAKE-VECTOR-WRITER MAKE-STRUCTURE-WRITER DEFINE-WRITER DEFINE-ACCESS-FUNCTIONS DEFINE-COPIER DEFINE-PRINT-FUNCTION PARSE-1-OPTION PARSE-NAME-AND-OPTIONS COMPILER-DEFSTRUCT DEFSTRUCT-DEFAULT-CONSTRUCTOR) (("deftype") EXPAND-DEFTYPE) (("delete-duplicates") LIST-DELETE-DUPLICATES* VECTOR-DELETE-DUPLICATES*) (("describe") DESCRIBE-ARGLIST %DESCRIBE-OBJECT) (("destructuring-bind") PARSE-BODY ARG-COUNT-ERROR PARSE-DEFMACRO DEFMACRO-ERROR VERIFY-KEYWORDS LOOKUP-KEYWORD KEYWORD-SUPPLIED-P PARSE-DEFMACRO-LAMBDA-LIST PUSH-SUB-LIST-BINDING PUSH-LET-BINDING PUSH-OPTIONAL-BINDING MAKE-EXPANDER-FOR-MACROLET) (("directory") PATHNAME-AS-FILE WILD-INFERIORS-P LIST-DIRECTORIES-WITH-WILDCARDS) (("do") DO-DO-BODY) (("dump-form") GET-INSTANCE-FORM DF-REGISTER-CIRCULARITY DF-CHECK-CONS DF-CHECK-VECTOR DF-CHECK-INSTANCE DF-CHECK-OBJECT DF-HANDLE-CIRCULARITY DUMP-CONS DUMP-VECTOR DUMP-INSTANCE DUMP-UNINTERNED-SYMBOL-INDEX DUMP-OBJECT DUMP-FORM) (("ed") DEFAULT-ED-FUNCTION) (("enough-namestring") EQUAL-COMPONENTS-P) (("fill") LIST-FILL VECTOR-FILL) (("find") LIST-POSITION* VECTOR-POSITION* LIST-FIND* VECTOR-FIND*) (("format") SYMBOLICATE PROPER-LIST-OF-LENGTH-P FLONUM-TO-STRING ROUND-UP SCALE-EXPONENT FLOAT-DENORMALIZED-P) (("inline") INLINE-EXPANSION SET-INLINE-EXPANSION) (("inspect") LEADER SAFE-LENGTH DISPLAY-OBJECT DISPLAY-CURRENT ISTEP) (("late-setf") MAKE-GENSYM-LIST) (("lcm") TWO-ARG-LCM) (("ldb") %LDB) (("load") LOAD-RETURNING-LAST-RESULT) (("make-sequence") SIZE-MISMATCH-ERROR) (("map1") MAP1) (("nsubstitute") NLIST-SUBSTITUTE* NVECTOR-SUBSTITUTE* NLIST-SUBSTITUTE-IF* NVECTOR-SUBSTITUTE-IF* NLIST-SUBSTITUTE-IF-NOT* NVECTOR-SUBSTITUTE-IF-NOT*) (("open") UPGRADED-ELEMENT-TYPE-BITS UPGRADED-ELEMENT-TYPE) (("parse-integer") PARSE-INTEGER-ERROR) (("parse-lambda-list") PARSE-LAMBDA-LIST-LIKE-THING PARSE-LAMBDA-LIST) (("pathnames") COMPONENT-MATCH-WILD-P COMPONENT-MATCH-P DIRECTORY-MATCH-COMPONENTS DIRECTORY-MATCH-P WILD-P CASIFY TRANSLATE-COMPONENT TRANSLATE-JAR-DEVICE TRANSLATE-DIRECTORY-COMPONENTS-AUX TRANSLATE-DIRECTORY-COMPONENTS TRANSLATE-DIRECTORY LOGICAL-HOST-P CANONICALIZE-LOGICAL-PATHNAME-TRANSLATIONS %SET-LOGICAL-PATHNAME-TRANSLATIONS) (("print-unreadable-object") %PRINT-UNREADABLE-OBJECT) (("print") COMPOUND-OBJECT-P OUTPUT-INTEGER OUTPUT-LIST OUTPUT-TERSE-ARRAY ARRAY-READABLY-PRINTABLE-P OUTPUT-VECTOR OUTPUT-UGLY-OBJECT CHECK-FOR-CIRCULARITY HANDLE-CIRCULARITY PRINT-LABEL PRINT-REFERENCE UNIQUELY-IDENTIFIED-BY-PRINT-P %PRINT-OBJECT %CHECK-OBJECT OUTPUT-OBJECT) (("proclaim") DECLARATION-ERROR CHECK-DECLARATION-TYPE PROCLAIM-TYPE PROCLAIMED-TYPE PROCLAIM-FTYPE-1 PROCLAIM-FTYPE PROCLAIMED-FTYPE FTYPE-RESULT-TYPE) (("query") QUERY-READLINE) (("read-circle") CIRCLE-SUBST SHARP-EQUAL SHARP-SHARP) (("read-conditional") READ-FEATURE READ-CONDITIONAL) (("remove-duplicates") LIST-REMOVE-DUPLICATES VECTOR-REMOVE-DUPLICATES) (("replace") LIST-REPLACE-FROM-LIST* LIST-REPLACE-FROM-VECTOR* VECTOR-REPLACE-FROM-LIST* VECTOR-REPLACE-FROM-VECTOR*) (("run-program") %MAKE-PROCESS MAKE-PROCESS %MAKE-PROCESS-BUILDER %PROCESS-BUILDER-ENVIRONMENT %PROCESS-BUILDER-ENV-PUT %PROCESS-BUILDER-ENV-CLEAR %PROCESS-BUILDER-START %MAKE-PROCESS-INPUT-STREAM %MAKE-PROCESS-OUTPUT-STREAM %MAKE-PROCESS-ERROR-STREAM %PROCESS-ALIVE-P %PROCESS-WAIT %PROCESS-EXIT-CODE %PROCESS-KILL) (("sequences") MAKE-SEQUENCE-OF-TYPE) (("setf") GET-SETF-METHOD-INVERSE EXPAND-OR-GET-SETF-INVERSE %SET-SUBSEQ %DEFINE-SETF-MACRO %SET-CAAR %SET-CADR %SET-CDAR %SET-CDDR %SET-CAAAR %SET-CADAR %SET-CDAAR %SET-CDDAR %SET-CAADR %SET-CADDR %SET-CDADR %SET-CDDDR %SET-CAAAAR %SET-CADAAR %SET-CDAAAR %SET-CDDAAR %SET-CAADAR %SET-CADDAR %SET-CDADAR %SET-CDDDAR %SET-CAAADR %SET-CADADR %SET-CDAADR %SET-CDDADR %SET-CAADDR %SET-CADDDR %SET-CDADDR %SET-CDDDDR %SET-FIFTH %SET-SIXTH %SET-SEVENTH %SET-EIGHTH %SET-NINTH %SET-TENTH) (("socket") %SOCKET-ADDRESS %SOCKET-PORT) (("sort") MERGE-SORT-VECTORS LAST-CONS-OF MERGE-LISTS MERGE-LISTS-NO-KEY SORT-LIST QUICKSORT QUICK-SORT) (("source-transform") SOURCE-TRANSFORM SET-SOURCE-TRANSFORM EXPAND-SOURCE-TRANSFORM-1 EXPAND-SOURCE-TRANSFORM) (("subst") %SUBST %SUBST-IF %SUBST-IF-NOT) (("subtypep") INITIALIZE-KNOWN-TYPES KNOWN-TYPE-P SUB-INTERVAL-P DIMENSION-SUBTYPEP SIMPLE-SUBTYPEP MAKE-CTYPE CTYPE-SUPER CTYPE-TYPE CTYPE CSUBTYPEP-ARRAY CSUBTYPEP-FUNCTION CSUBTYPEP-COMPLEX CSUBTYPEP %SUBTYPEP) (("time") PICK-OBVIOUS-YEAR LEAP-YEARS-BEFORE) (("trace") MAKE-TRACE-INFO TRACE-INFO-P LIST-TRACED-FUNCTIONS EXPAND-TRACE TRACE-1 TRACED-FUNCTION INDENT UNTRACE-ALL UNTRACE-1) (("tree-equal") TREE-EQUAL-TEST-NOT TREE-EQUAL-TEST) (("typep") SIMPLE-ARRAY-P IN-INTERVAL-P MATCH-DIMENSIONS %TYPEP) (("with-hash-table-iterator") HASH-TABLE-ITERATOR-FUNCTION) (("with-package-iterator") PACKAGE-ITERATOR-FUNCTION) (("with-standard-io-syntax") %WITH-STANDARD-IO-SYNTAX)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR FS) (CAR (CAR FS)))) +(DOLIST (FS (QUOTE ((("abcl-contrib") FIND-SYSTEM-JAR FIND-CONTRIB) (("assert") ASSERT-ERROR ASSERT-PROMPT) (("aver") %FAILED-AVER) (("backquote") BACKQUOTE-MACRO COMMA-MACRO EXPANDABLE-BACKQ-EXPRESSION-P BACKQUOTIFY COMMA BACKQUOTIFY-1 BACKQ-LIST BACKQ-LIST* BACKQ-APPEND BACKQ-NCONC BACKQ-CONS BACKQ-VECTOR %READER-ERROR) (("bit-array-ops") BIT-ARRAY-SAME-DIMENSIONS-P REQUIRE-SAME-DIMENSIONS PICK-RESULT-ARRAY) (("case") LIST-OF-LENGTH-AT-LEAST-P CASE-BODY-ERROR CASE-BODY-AUX CASE-BODY) (("check-type") CHECK-TYPE-ERROR) (("clos") COERCE-TO-CONDITION) (("coerce") COERCE-LIST-TO-VECTOR COPY-STRING COERCE-ERROR COERCE-OBJECT-TO-AND-TYPE) (("compile-file-pathname") CFP-OUTPUT-FILE-DEFAULT) (("compile-file") BASE-CLASSNAME FASL-LOADER-CLASSNAME COMPUTE-CLASSFILE-NAME SANITIZE-CLASS-NAME NEXT-CLASSFILE-NAME DUMMY VERIFY-LOAD NOTE-TOPLEVEL-FORM OUTPUT-FORM FINALIZE-FASL-OUTPUT SIMPLE-TOPLEVEL-FORM-P CONVERT-TOPLEVEL-FORM PROCESS-PROGN PRECOMPILE-TOPLEVEL-FORM PROCESS-TOPLEVEL-MACROLET PROCESS-TOPLEVEL-DEFCONSTANT PROCESS-TOPLEVEL-QUOTE PROCESS-TOPLEVEL-IMPORT PROCESS-TOPLEVEL-EXPORT PROCESS-TOPLEVEL-MOP.ENSURE-METHOD PROCESS-TOPLEVEL-DEFVAR/DEFPARAMETER PROCESS-TOPLEVEL-DEFPACKAGE/IN-PACKAGE PROCESS-TOPLEVEL-DECLARE PROCESS-TOPLEVEL-PROGN PROCESS-TOPLEVEL-DEFTYPE PROCESS-TOPLEVEL-EVAL-WHEN PROCESS-TOPLEVEL-DEFMETHOD/DEFGENERIC PROCESS-TOPLEVEL-LOCALLY PROCESS-TOPLEVEL-DEFMACRO PROCESS-TOPLEVEL-DEFUN INSTALL-TOPLEVEL-HANDLER PROCESS-TOPLEVEL-FORM POPULATE-ZIP-FASL WRITE-FASL-PROLOGUE COMPILE-FROM-STREAM) (("compile-system") CHECK-LISP-HOME GROVEL-JAVA-DEFINITIONS-IN-FILE PACKAGES-FROM-COMBOS REMOVE-MULTI-COMBO-SYMBOLS SET-EQUAL COMBOS-TO-SYMBOL-FILESETS COMBOS-TO-FILESET-SYMBOLS WRITE-AUTOLOADER WRITE-PACKAGE-FILESETS LOAD-COMBOS GENERATE-AUTOLOADS %COMPILE-SYSTEM CREATE-SYSTEM-LOGICAL-TRANSLATIONS) (("compiler-error") COMPILER-STYLE-WARN COMPILER-WARN COMPILER-ERROR INTERNAL-COMPILER-ERROR COMPILER-UNSUPPORTED) (("compiler-macro") COMPILER-MACROEXPAND-1 COMPILER-MACROEXPAND) (("compiler-pass2") AUTOCOMPILE) (("compiler-types") MAKE-CONSTANT-TYPE CONSTANT-TYPE-P %MAKE-INTEGER-TYPE INTEGER-TYPE-P MAKE-INTEGER-TYPE FIXNUM-TYPE-P FIXNUM-CONSTANT-VALUE INTEGER-CONSTANT-VALUE JAVA-LONG-TYPE-P MAKE-UNION-TYPE MAKE-COMPILER-TYPE INTEGER-TYPE-SUBTYPEP COMPILER-SUBTYPEP FUNCTION-RESULT-TYPE SET-FUNCTION-RESULT-TYPE %DEFKNOWN) (("concatenate") CONCATENATE-TO-STRING) (("debug") INTERNAL-DEBUG DEBUG-LOOP INVOKE-DEBUGGER-REPORT-CONDITION RUN-HOOK BACKTRACE-AS-LIST) (("define-symbol-macro") %DEFINE-SYMBOL-MACRO) (("defpackage") DESIGNATED-PACKAGE-NAME STRINGIFY-NAMES CHECK-DISJOINT) (("defsetf") %DEFSETF) (("defstruct") MAKE-DEFSTRUCT-DESCRIPTION MAKE-DEFSTRUCT-SLOT-DESCRIPTION KEYWORDIFY DEFINE-KEYWORD-CONSTRUCTOR FIND-DSD GET-SLOT DEFINE-BOA-CONSTRUCTOR DEFAULT-CONSTRUCTOR-NAME DEFINE-CONSTRUCTORS NAME-INDEX DEFINE-PREDICATE MAKE-LIST-READER MAKE-VECTOR-READER MAKE-STRUCTURE-READER DEFINE-READER MAKE-LIST-WRITER MAKE-VECTOR-WRITER MAKE-STRUCTURE-WRITER DEFINE-WRITER DEFINE-ACCESS-FUNCTIONS DEFINE-COPIER DEFINE-PRINT-FUNCTION PARSE-1-OPTION PARSE-NAME-AND-OPTIONS COMPILER-DEFSTRUCT DEFSTRUCT-DEFAULT-CONSTRUCTOR) (("deftype") EXPAND-DEFTYPE) (("delete-duplicates") LIST-DELETE-DUPLICATES* VECTOR-DELETE-DUPLICATES*) (("describe") DESCRIBE-ARGLIST %DESCRIBE-OBJECT) (("destructuring-bind") PARSE-BODY ARG-COUNT-ERROR PARSE-DEFMACRO DEFMACRO-ERROR VERIFY-KEYWORDS LOOKUP-KEYWORD KEYWORD-SUPPLIED-P PARSE-DEFMACRO-LAMBDA-LIST PUSH-SUB-LIST-BINDING PUSH-LET-BINDING PUSH-OPTIONAL-BINDING MAKE-EXPANDER-FOR-MACROLET) (("directory") PATHNAME-AS-FILE WILD-INFERIORS-P LIST-DIRECTORIES-WITH-WILDCARDS) (("do") DO-DO-BODY) (("dump-form") GET-INSTANCE-FORM DF-REGISTER-CIRCULARITY DF-CHECK-CONS DF-CHECK-VECTOR DF-CHECK-INSTANCE DF-CHECK-OBJECT DF-HANDLE-CIRCULARITY DUMP-CONS DUMP-VECTOR DUMP-INSTANCE DUMP-UNINTERNED-SYMBOL-INDEX DUMP-OBJECT DUMP-FORM) (("ed") DEFAULT-ED-FUNCTION) (("enough-namestring") EQUAL-COMPONENTS-P) (("fill") LIST-FILL VECTOR-FILL) (("find") LIST-POSITION* VECTOR-POSITION* LIST-FIND* VECTOR-FIND*) (("format") SYMBOLICATE PROPER-LIST-OF-LENGTH-P FLONUM-TO-STRING ROUND-UP SCALE-EXPONENT FLOAT-DENORMALIZED-P) (("inline") INLINE-EXPANSION SET-INLINE-EXPANSION) (("inspect") LEADER SAFE-LENGTH DISPLAY-OBJECT DISPLAY-CURRENT ISTEP) (("late-setf") MAKE-GENSYM-LIST) (("lcm") TWO-ARG-LCM) (("ldb") %LDB) (("load") LOAD-RETURNING-LAST-RESULT) (("make-sequence") SIZE-MISMATCH-ERROR) (("map1") MAP1) (("nsubstitute") NLIST-SUBSTITUTE* NVECTOR-SUBSTITUTE* NLIST-SUBSTITUTE-IF* NVECTOR-SUBSTITUTE-IF* NLIST-SUBSTITUTE-IF-NOT* NVECTOR-SUBSTITUTE-IF-NOT*) (("open") UPGRADED-ELEMENT-TYPE-BITS UPGRADED-ELEMENT-TYPE) (("parse-integer") PARSE-INTEGER-ERROR) (("parse-lambda-list") PARSE-LAMBDA-LIST-LIKE-THING PARSE-LAMBDA-LIST) (("pathnames") COMPONENT-MATCH-WILD-P COMPONENT-MATCH-P DIRECTORY-MATCH-COMPONENTS DIRECTORY-MATCH-P WILD-P CASIFY TRANSLATE-COMPONENT TRANSLATE-JAR-DEVICE TRANSLATE-DIRECTORY-COMPONENTS-AUX TRANSLATE-DIRECTORY-COMPONENTS TRANSLATE-DIRECTORY LOGICAL-HOST-P CANONICALIZE-LOGICAL-PATHNAME-TRANSLATIONS %SET-LOGICAL-PATHNAME-TRANSLATIONS) (("print-unreadable-object") %PRINT-UNREADABLE-OBJECT) (("print") COMPOUND-OBJECT-P OUTPUT-INTEGER OUTPUT-LIST OUTPUT-TERSE-ARRAY ARRAY-READABLY-PRINTABLE-P OUTPUT-VECTOR OUTPUT-UGLY-OBJECT CHECK-FOR-CIRCULARITY HANDLE-CIRCULARITY PRINT-LABEL PRINT-REFERENCE UNIQUELY-IDENTIFIED-BY-PRINT-P %PRINT-OBJECT %CHECK-OBJECT OUTPUT-OBJECT) (("proclaim") DECLARATION-ERROR CHECK-DECLARATION-TYPE PROCLAIM-TYPE PROCLAIMED-TYPE PROCLAIM-FTYPE-1 PROCLAIM-FTYPE PROCLAIMED-FTYPE FTYPE-RESULT-TYPE) (("query") QUERY-READLINE) (("read-circle") CIRCLE-SUBST SHARP-EQUAL SHARP-SHARP) (("read-conditional") READ-FEATURE READ-CONDITIONAL) (("remove-duplicates") LIST-REMOVE-DUPLICATES VECTOR-REMOVE-DUPLICATES) (("replace") LIST-REPLACE-FROM-LIST* LIST-REPLACE-FROM-VECTOR* VECTOR-REPLACE-FROM-LIST* VECTOR-REPLACE-FROM-VECTOR*) (("run-program") %MAKE-PROCESS MAKE-PROCESS %MAKE-PROCESS-BUILDER %PROCESS-BUILDER-ENVIRONMENT %PROCESS-BUILDER-ENV-PUT %PROCESS-BUILDER-ENV-CLEAR %PROCESS-BUILDER-START %MAKE-PROCESS-INPUT-STREAM %MAKE-PROCESS-OUTPUT-STREAM %MAKE-PROCESS-ERROR-STREAM %PROCESS-ALIVE-P %PROCESS-WAIT %PROCESS-EXIT-CODE %PROCESS-KILL) (("sequences") MAKE-SEQUENCE-OF-TYPE) (("setf") GET-SETF-METHOD-INVERSE EXPAND-OR-GET-SETF-INVERSE %SET-SUBSEQ %DEFINE-SETF-MACRO %SET-CAAR %SET-CADR %SET-CDAR %SET-CDDR %SET-CAAAR %SET-CADAR %SET-CDAAR %SET-CDDAR %SET-CAADR %SET-CADDR %SET-CDADR %SET-CDDDR %SET-CAAAAR %SET-CADAAR %SET-CDAAAR %SET-CDDAAR %SET-CAADAR %SET-CADDAR %SET-CDADAR %SET-CDDDAR %SET-CAAADR %SET-CADADR %SET-CDAADR %SET-CDDADR %SET-CAADDR %SET-CADDDR %SET-CDADDR %SET-CDDDDR %SET-FIFTH %SET-SIXTH %SET-SEVENTH %SET-EIGHTH %SET-NINTH %SET-TENTH) (("sort") MERGE-SORT-VECTORS LAST-CONS-OF MERGE-LISTS MERGE-LISTS-NO-KEY SORT-LIST QUICKSORT QUICK-SORT) (("source-transform") SOURCE-TRANSFORM SET-SOURCE-TRANSFORM EXPAND-SOURCE-TRANSFORM-1 EXPAND-SOURCE-TRANSFORM) (("subst") %SUBST %SUBST-IF %SUBST-IF-NOT) (("subtypep") INITIALIZE-KNOWN-TYPES KNOWN-TYPE-P SUB-INTERVAL-P DIMENSION-SUBTYPEP SIMPLE-SUBTYPEP MAKE-CTYPE CTYPE-SUPER CTYPE-TYPE CTYPE CSUBTYPEP-ARRAY CSUBTYPEP-FUNCTION CSUBTYPEP-COMPLEX CSUBTYPEP %SUBTYPEP) (("time") PICK-OBVIOUS-YEAR LEAP-YEARS-BEFORE) (("trace") MAKE-TRACE-INFO TRACE-INFO-P LIST-TRACED-FUNCTIONS EXPAND-TRACE TRACE-1 TRACED-FUNCTION UNTRACED-FUNCTION TRACE-REDEFINED-UPDATE INDENT UNTRACE-ALL UNTRACE-1) (("tree-equal") TREE-EQUAL-TEST-NOT TREE-EQUAL-TEST) (("typep") SIMPLE-ARRAY-P IN-INTERVAL-P MATCH-DIMENSIONS %TYPEP) (("with-hash-table-iterator") HASH-TABLE-ITERATOR-FUNCTION) (("with-package-iterator") PACKAGE-ITERATOR-FUNCTION) (("with-standard-io-syntax") %WITH-STANDARD-IO-SYNTAX)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR FS) (CAR (CAR FS)))) + +;; MACROS + (IN-PACKAGE :SYSTEM) -(DOLIST (FS (QUOTE ((("assoc") ASSOC-GUTS) (("chars") EQUAL-CHAR-CODE) (("compile-file") REPORT-ERROR DIAG) (("compiler-types") DEFKNOWN) (("copy-seq") VECTOR-COPY-SEQ LIST-COPY-SEQ) (("define-modify-macro") INCF-COMPLEX DECF-COMPLEX) (("defstruct") DD-NAME DD-CONC-NAME DD-DEFAULT-CONSTRUCTOR DD-CONSTRUCTORS DD-COPIER DD-INCLUDE DD-TYPE DD-NAMED DD-INITIAL-OFFSET DD-PREDICATE DD-PRINT-FUNCTION DD-PRINT-OBJECT DD-DIRECT-SLOTS DD-SLOTS DD-INHERITED-ACCESSORS DSD-NAME DSD-INDEX DSD-READER DSD-INITFORM DSD-TYPE DSD-READ-ONLY) (("delete") MUMBLE-DELETE MUMBLE-DELETE-FROM-END NORMAL-MUMBLE-DELETE NORMAL-MUMBLE-DELETE-FROM-END LIST-DELETE LIST-DELETE-FROM-END NORMAL-LIST-DELETE NORMAL-LIST-DELETE-FROM-END IF-MUMBLE-DELETE IF-MUMBLE-DELETE-FROM-END IF-LIST-DELETE IF-LIST-DELETE-FROM-END IF-NOT-MUMBLE-DELETE IF-NOT-MUMBLE-DELETE-FROM-END IF-NOT-LIST-DELETE IF-NOT-LIST-DELETE-FROM-END) (("find") VECTOR-LOCATER-MACRO LOCATER-TEST-NOT VECTOR-LOCATER LOCATER-IF-TEST VECTOR-LOCATER-IF-MACRO VECTOR-LOCATER-IF VECTOR-LOCATER-IF-NOT LIST-LOCATER-MACRO LIST-LOCATER LIST-LOCATER-IF-MACRO LIST-LOCATER-IF LIST-LOCATER-IF-NOT VECTOR-POSITION LIST-POSITION VECTOR-POSITION-IF LIST-POSITION-IF VECTOR-POSITION-IF-NOT LIST-POSITION-IF-NOT VECTOR-FIND LIST-FIND VECTOR-FIND-IF LIST-FIND-IF VECTOR-FIND-IF-NOT LIST-FIND-IF-NOT) (("format") NAMED-LET ONCE-ONLY) (("list") APPLY-KEY) (("print") PUNT-PRINT-IF-TOO-LONG) (("reduce") LIST-REDUCE LIST-REDUCE-FROM-END) (("remove") MUMBLE-REMOVE-MACRO MUMBLE-REMOVE MUMBLE-REMOVE-FROM-END NORMAL-MUMBLE-REMOVE NORMAL-MUMBLE-REMOVE-FROM-END IF-MUMBLE-REMOVE IF-MUMBLE-REMOVE-FROM-END IF-NOT-MUMBLE-REMOVE IF-NOT-MUMBLE-REMOVE-FROM-END LIST-REMOVE-MACRO LIST-REMOVE LIST-REMOVE-FROM-END NORMAL-LIST-REMOVE NORMAL-LIST-REMOVE-FROM-END IF-LIST-REMOVE IF-LIST-REMOVE-FROM-END IF-NOT-LIST-REMOVE IF-NOT-LIST-REMOVE-FROM-END) (("sequences") TYPE-SPECIFIER-ATOM MAKE-SEQUENCE-LIKE) (("sets") WITH-SET-KEYS STEVE-SPLICE) (("sort") MERGE-VECTORS-BODY MERGE-SORT-BODY QUICKSORT-BODY) (("source-transform") DEFINE-SOURCE-TRANSFORM) (("subst") SATISFIES-THE-TEST)))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR FS) (CAR (CAR FS)))) +(DOLIST (FS (QUOTE ((("assoc") ASSOC-GUTS) (("chars") EQUAL-CHAR-CODE) (("compile-file") REPORT-ERROR DIAG) (("compiler-types") DEFKNOWN) (("copy-seq") VECTOR-COPY-SEQ LIST-COPY-SEQ) (("define-modify-macro") INCF-COMPLEX DECF-COMPLEX) (("defstruct") DD-NAME DD-CONC-NAME DD-DEFAULT-CONSTRUCTOR DD-CONSTRUCTORS DD-COPIER DD-INCLUDE DD-TYPE DD-NAMED DD-INITIAL-OFFSET DD-PREDICATE DD-PRINT-FUNCTION DD-PRINT-OBJECT DD-DIRECT-SLOTS DD-SLOTS DD-INHERITED-ACCESSORS DSD-NAME DSD-INDEX DSD-READER DSD-INITFORM DSD-TYPE DSD-READ-ONLY) (("delete") MUMBLE-DELETE MUMBLE-DELETE-FROM-END NORMAL-MUMBLE-DELETE NORMAL-MUMBLE-DELETE-FROM-END LIST-DELETE LIST-DELETE-FROM-END NORMAL-LIST-DELETE NORMAL-LIST-DELETE-FROM-END IF-MUMBLE-DELETE IF-MUMBLE-DELETE-FROM-END IF-LIST-DELETE IF-LIST-DELETE-FROM-END IF-NOT-MUMBLE-DELETE IF-NOT-MUMBLE-DELETE-FROM-END IF-NOT-LIST-DELETE IF-NOT-LIST-DELETE-FROM-END) (("find") VECTOR-LOCATER-MACRO LOCATER-TEST-NOT VECTOR-LOCATER LOCATER-IF-TEST VECTOR-LOCATER-IF-MACRO VECTOR-LOCATER-IF VECTOR-LOCATER-IF-NOT LIST-LOCATER-MACRO LIST-LOCATER LIST-LOCATER-IF-MACRO LIST-LOCATER-IF LIST-LOCATER-IF-NOT VECTOR-POSITION LIST-POSITION VECTOR-POSITION-IF LIST-POSITION-IF VECTOR-POSITION-IF-NOT LIST-POSITION-IF-NOT VECTOR-FIND LIST-FIND VECTOR-FIND-IF LIST-FIND-IF VECTOR-FIND-IF-NOT LIST-FIND-IF-NOT) (("format") NAMED-LET ONCE-ONLY) (("list") APPLY-KEY) (("print") PUNT-PRINT-IF-TOO-LONG) (("reduce") LIST-REDUCE LIST-REDUCE-FROM-END) (("remove") MUMBLE-REMOVE-MACRO MUMBLE-REMOVE MUMBLE-REMOVE-FROM-END NORMAL-MUMBLE-REMOVE NORMAL-MUMBLE-REMOVE-FROM-END IF-MUMBLE-REMOVE IF-MUMBLE-REMOVE-FROM-END IF-NOT-MUMBLE-REMOVE IF-NOT-MUMBLE-REMOVE-FROM-END LIST-REMOVE-MACRO LIST-REMOVE LIST-REMOVE-FROM-END NORMAL-LIST-REMOVE NORMAL-LIST-REMOVE-FROM-END IF-LIST-REMOVE IF-LIST-REMOVE-FROM-END IF-NOT-LIST-REMOVE IF-NOT-LIST-REMOVE-FROM-END) (("sequences") TYPE-SPECIFIER-ATOM MAKE-SEQUENCE-LIKE) (("sets") WITH-SET-KEYS STEVE-SPLICE) (("sort") MERGE-VECTORS-BODY MERGE-SORT-BODY QUICKSORT-BODY) (("source-transform") DEFINE-SOURCE-TRANSFORM) (("subst") SATISFIES-THE-TEST)))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR FS) (CAR (CAR FS)))) +;; EXPORTS +(IN-PACKAGE :CL) +(EXPORT (QUOTE (NBUTLAST BUTLAST IGNORE-ERRORS MAP-INTO MISMATCH METHOD-QUALIFIERS COMPUTE-APPLICABLE-METHODS STANDARD-METHOD SUBSTITUTE-IF-NOT SUBSTITUTE-IF SUBSTITUTE))) + +;; FUNCTIONS + (IN-PACKAGE :CL) -(DOLIST (SYSTEM::FS (QUOTE ((("adjoin") ADJOIN) (("apropos") APROPOS-LIST APROPOS) (("arrays") MAKE-ARRAY ADJUST-ARRAY ARRAY-ROW-MAJOR-INDEX BIT SBIT) (("assoc") ASSOC ASSOC-IF ASSOC-IF-NOT RASSOC RASSOC-IF RASSOC-IF-NOT ACONS PAIRLIS COPY-ALIST) (("bit-array-ops") BIT-AND BIT-IOR BIT-XOR BIT-EQV BIT-NAND BIT-NOR BIT-ANDC1 BIT-ANDC2 BIT-ORC1 BIT-ORC2 BIT-NOT) (("boole") BOOLE) (("butlast") BUTLAST NBUTLAST) (("byte-io") WRITE-BYTE READ-BYTE) (("chars") CHAR/= CHAR> CHAR>= CHAR-NOT-EQUAL) (("clos") CLASS-NAME NO-APPLICABLE-METHOD FUNCTION-KEYWORDS SLOT-VALUE SLOT-BOUNDP SLOT-MAKUNBOUND SLOT-EXISTS-P METHOD-QUALIFIERS ENSURE-GENERIC-FUNCTION COMPUTE-APPLICABLE-METHODS DOCUMENTATION SLOT-MISSING SLOT-UNBOUND ALLOCATE-INSTANCE INITIALIZE-INSTANCE REINITIALIZE-INSTANCE CHANGE-CLASS UPDATE-INSTANCE-FOR-DIFFERENT-CLASS MAKE-INSTANCES-OBSOLETE UPDATE-INSTANCE-FOR-REDEFINED-CLASS MAKE-CONDITION INVALID-METHOD-ERROR METHOD-COMBINATION-ERROR FIND-METHOD ADD-METHOD REMOVE-METHOD NO-NEXT-METHOD) (("coerce") COERCE) (("compile-file-pathname") COMPILE-FILE-PATHNAME) (("compile-file") COMPILE-FILE) (("compiler-macro") COMPILER-MACRO-FUNCTION) (("concatenate") CONCATENATE) (("copy-seq") COPY-SEQ) (("copy-symbol") COPY-SYMBOL) (("count") COUNT COUNT-IF COUNT-IF-NOT) (("debug") INVOKE-DEBUGGER BREAK) (("delete-duplicates") DELETE-DUPLICATES) (("delete") DELETE DELETE-IF DELETE-IF-NOT) (("deposit-field") DEPOSIT-FIELD) (("describe") DESCRIBE) (("directory") DIRECTORY) (("disassemble") DISASSEMBLE) (("dribble") DRIBBLE) (("ed") ED) (("enough-namestring") ENOUGH-NAMESTRING) (("ensure-directories-exist") ENSURE-DIRECTORIES-EXIST) (("fill") FILL) (("find-all-symbols") FIND-ALL-SYMBOLS) (("find") POSITION POSITION-IF POSITION-IF-NOT FIND FIND-IF FIND-IF-NOT) (("format") FORMAT) (("gentemp") GENTEMP) (("inspect") INSPECT) (("lcm") LCM) (("ldb") BYTE BYTE-SIZE BYTE-POSITION LDB LDB-TEST DPB) (("ldiff") LDIFF) (("list-length") LIST-LENGTH) (("list") FIFTH SIXTH SEVENTH EIGHTH NINTH TENTH MAKE-LIST COMPLEMENT CONSTANTLY MEMBER) (("load") LOAD) (("make-hash-table") MAKE-HASH-TABLE) (("make-load-form-saving-slots") MAKE-LOAD-FORM-SAVING-SLOTS) (("make-sequence") MAKE-SEQUENCE) (("make-string-output-stream") MAKE-STRING-OUTPUT-STREAM) (("make-string") MAKE-STRING) (("map-into") MAP-INTO) (("map") MAP) (("map1") MAPCAN MAPL MAPLIST MAPCON) (("mask-field") MASK-FIELD) (("member-if") MEMBER-IF MEMBER-IF-NOT) (("mismatch") BAD-SEQ-LIMIT THE-END THE-START CALL-TEST TEST-ERROR MISMATCH) (("nsubstitute") NSUBSTITUTE NSUBSTITUTE-IF NSUBSTITUTE-IF-NOT) (("numbers") SIGNUM ROUND FFLOOR FCEILING FROUND RATIONALIZE GCD ISQRT FLOAT-PRECISION DECODE-FLOAT CONJUGATE PHASE) (("open") OPEN) (("package") MAKE-PACKAGE IMPORT DELETE-PACKAGE) (("parse-integer") PARSE-INTEGER) (("pathnames") PATHNAME-HOST PATHNAME-DEVICE PATHNAME-DIRECTORY PATHNAME-NAME PATHNAME-TYPE WILD-PATHNAME-P PATHNAME-MATCH-P TRANSLATE-PATHNAME LOGICAL-PATHNAME-TRANSLATIONS TRANSLATE-LOGICAL-PATHNAME LOAD-LOGICAL-PATHNAME-TRANSLATIONS LOGICAL-PATHNAME PARSE-NAMESTRING) (("pprint-dispatch") COPY-PPRINT-DISPATCH SET-PPRINT-DISPATCH PPRINT-DISPATCH) (("pprint") WRITE PRINT PRIN1 PRINC PPRINT WRITE-TO-STRING PRIN1-TO-STRING PRINC-TO-STRING WRITE-CHAR WRITE-STRING WRITE-LINE TERPRI FRESH-LINE FINISH-OUTPUT FORCE-OUTPUT CLEAR-OUTPUT PPRINT-NEWLINE PPRINT-INDENT PPRINT-TAB PPRINT-LINEAR PPRINT-FILL PPRINT-TABULAR) (("proclaim") PROCLAIM) (("query") Y-OR-N-P YES-OR-NO-P) (("read-from-string") READ-FROM-STRING) (("read-sequence") READ-SEQUENCE) (("reduce") REDUCE) (("remove-duplicates") REMOVE-DUPLICATES) (("remove") REMOVE REMOVE-IF REMOVE-IF-NOT) (("replace") REPLACE) (("revappend") REVAPPEND) (("search") SEARCH) (("setf") GET-SETF-EXPANSION) (("sets") UNION NUNION INTERSECTION NINTERSECTION SET-DIFFERENCE NSET-DIFFERENCE SET-EXCLUSIVE-OR NSET-EXCLUSIVE-OR SUBSETP) (("sort") MERGE SORT STABLE-SORT) (("strings") STRING-UPCASE STRING-DOWNCASE STRING-CAPITALIZE NSTRING-UPCASE NSTRING-DOWNCASE NSTRING-CAPITALIZE STRING= STRING/= STRING-EQUAL STRING-NOT-EQUAL STRING< STRING> STRING<= STRING>= STRING-LESSP STRING-GREATERP STRING-NOT-LESSP STRING-NOT-GREATERP STRING-LEFT-TRIM STRING-RIGHT-TRIM STRING-TRIM) (("sublis") SUBLIS NSUBLIS) (("subst") SUBST SUBST-IF SUBST-IF-NOT NSUBST NSUBST-IF NSUBST-IF-NOT) (("substitute") LIST-SUBSTITUTE* VECTOR-SUBSTITUTE* SUBSTITUTE SUBSTITUTE-IF SUBSTITUTE-IF-NOT) (("subtypep") SUBTYPEP) (("tailp") TAILP) (("time") DECODE-UNIVERSAL-TIME GET-DECODED-TIME ENCODE-UNIVERSAL-TIME) (("tree-equal") TREE-EQUAL) (("typep") TYPEP) (("upgraded-complex-part-type") UPGRADED-COMPLEX-PART-TYPE) (("write-sequence") WRITE-SEQUENCE)))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(DOLIST (SYSTEM::FS (QUOTE ((("adjoin") ADJOIN) (("apropos") APROPOS-LIST APROPOS) (("arrays") MAKE-ARRAY ADJUST-ARRAY ARRAY-ROW-MAJOR-INDEX BIT SBIT) (("assoc") ASSOC ASSOC-IF ASSOC-IF-NOT RASSOC RASSOC-IF RASSOC-IF-NOT ACONS PAIRLIS COPY-ALIST) (("bit-array-ops") BIT-AND BIT-IOR BIT-XOR BIT-EQV BIT-NAND BIT-NOR BIT-ANDC1 BIT-ANDC2 BIT-ORC1 BIT-ORC2 BIT-NOT) (("boole") BOOLE) (("butlast") BUTLAST NBUTLAST) (("byte-io") WRITE-BYTE READ-BYTE) (("chars") CHAR/= CHAR> CHAR>= CHAR-NOT-EQUAL) (("clos") CLASS-NAME NO-APPLICABLE-METHOD FUNCTION-KEYWORDS SLOT-VALUE SLOT-BOUNDP SLOT-MAKUNBOUND SLOT-EXISTS-P METHOD-QUALIFIERS ENSURE-GENERIC-FUNCTION COMPUTE-APPLICABLE-METHODS DOCUMENTATION SLOT-MISSING SLOT-UNBOUND ALLOCATE-INSTANCE INITIALIZE-INSTANCE REINITIALIZE-INSTANCE CHANGE-CLASS UPDATE-INSTANCE-FOR-DIFFERENT-CLASS MAKE-INSTANCES-OBSOLETE UPDATE-INSTANCE-FOR-REDEFINED-CLASS MAKE-CONDITION INVALID-METHOD-ERROR METHOD-COMBINATION-ERROR FIND-METHOD ADD-METHOD REMOVE-METHOD NO-NEXT-METHOD) (("coerce") COERCE) (("compile-file-pathname") COMPILE-FILE-PATHNAME) (("compile-file") COMPILE-FILE) (("compiler-macro") COMPILER-MACRO-FUNCTION) (("compiler-pass2") COMPILE) (("concatenate") CONCATENATE) (("copy-seq") COPY-SEQ) (("copy-symbol") COPY-SYMBOL) (("count") COUNT COUNT-IF COUNT-IF-NOT) (("debug") INVOKE-DEBUGGER BREAK) (("delete-duplicates") DELETE-DUPLICATES) (("delete") DELETE DELETE-IF DELETE-IF-NOT) (("deposit-field") DEPOSIT-FIELD) (("describe") DESCRIBE) (("directory") DIRECTORY) (("disassemble") DISASSEMBLE) (("dribble") DRIBBLE) (("ed") ED) (("enough-namestring") ENOUGH-NAMESTRING) (("ensure-directories-exist") ENSURE-DIRECTORIES-EXIST) (("fill") FILL) (("find-all-symbols") FIND-ALL-SYMBOLS) (("find") POSITION POSITION-IF POSITION-IF-NOT FIND FIND-IF FIND-IF-NOT) (("format") FORMAT) (("gentemp") GENTEMP) (("inspect") INSPECT) (("lcm") LCM) (("ldb") BYTE BYTE-SIZE BYTE-POSITION LDB LDB-TEST DPB) (("ldiff") LDIFF) (("list-length") LIST-LENGTH) (("list") FIFTH SIXTH SEVENTH EIGHTH NINTH TENTH MAKE-LIST COMPLEMENT CONSTANTLY MEMBER) (("load") LOAD) (("make-hash-table") MAKE-HASH-TABLE) (("make-load-form-saving-slots") MAKE-LOAD-FORM-SAVING-SLOTS) (("make-sequence") MAKE-SEQUENCE) (("make-string-output-stream") MAKE-STRING-OUTPUT-STREAM) (("make-string") MAKE-STRING) (("map-into") MAP-INTO) (("map") MAP) (("map1") MAPCAN MAPL MAPLIST MAPCON) (("mask-field") MASK-FIELD) (("member-if") MEMBER-IF MEMBER-IF-NOT) (("mismatch") BAD-SEQ-LIMIT THE-END THE-START CALL-TEST TEST-ERROR MISMATCH) (("nsubstitute") NSUBSTITUTE NSUBSTITUTE-IF NSUBSTITUTE-IF-NOT) (("numbers") SIGNUM ROUND FFLOOR FCEILING FROUND RATIONALIZE GCD ISQRT FLOAT-PRECISION DECODE-FLOAT CONJUGATE PHASE) (("open") OPEN) (("package") MAKE-PACKAGE IMPORT DELETE-PACKAGE) (("parse-integer") PARSE-INTEGER) (("pathnames") PATHNAME-HOST PATHNAME-DEVICE PATHNAME-DIRECTORY PATHNAME-NAME PATHNAME-TYPE WILD-PATHNAME-P PATHNAME-MATCH-P TRANSLATE-PATHNAME LOGICAL-PATHNAME-TRANSLATIONS TRANSLATE-LOGICAL-PATHNAME LOAD-LOGICAL-PATHNAME-TRANSLATIONS LOGICAL-PATHNAME PARSE-NAMESTRING) (("pprint-dispatch") COPY-PPRINT-DISPATCH SET-PPRINT-DISPATCH PPRINT-DISPATCH) (("pprint") WRITE PRINT PRIN1 PRINC PPRINT WRITE-TO-STRING PRIN1-TO-STRING PRINC-TO-STRING WRITE-CHAR WRITE-STRING WRITE-LINE TERPRI FRESH-LINE FINISH-OUTPUT FORCE-OUTPUT CLEAR-OUTPUT PPRINT-NEWLINE PPRINT-INDENT PPRINT-TAB PPRINT-LINEAR PPRINT-FILL PPRINT-TABULAR) (("proclaim") PROCLAIM) (("query") Y-OR-N-P YES-OR-NO-P) (("read-from-string") READ-FROM-STRING) (("read-sequence") READ-SEQUENCE) (("reduce") REDUCE) (("remove-duplicates") REMOVE-DUPLICATES) (("remove") REMOVE REMOVE-IF REMOVE-IF-NOT) (("replace") REPLACE) (("revappend") REVAPPEND) (("search") SEARCH) (("setf") GET-SETF-EXPANSION) (("sets") UNION NUNION INTERSECTION NINTERSECTION SET-DIFFERENCE NSET-DIFFERENCE SET-EXCLUSIVE-OR NSET-EXCLUSIVE-OR SUBSETP) (("sort") MERGE SORT STABLE-SORT) (("strings") STRING-UPCASE STRING-DOWNCASE STRING-CAPITALIZE NSTRING-UPCASE NSTRING-DOWNCASE NSTRING-CAPITALIZE STRING= STRING/= STRING-EQUAL STRING-NOT-EQUAL STRING< STRING> STRING<= STRING>= STRING-LESSP STRING-GREATERP STRING-NOT-LESSP STRING-NOT-GREATERP STRING-LEFT-TRIM STRING-RIGHT-TRIM STRING-TRIM) (("sublis") SUBLIS NSUBLIS) (("subst") SUBST SUBST-IF SUBST-IF-NOT NSUBST NSUBST-IF NSUBST-IF-NOT) (("substitute") LIST-SUBSTITUTE* VECTOR-SUBSTITUTE* SUBSTITUTE SUBSTITUTE-IF SUBSTITUTE-IF-NOT) (("subtypep") SUBTYPEP) (("tailp") TAILP) (("time") DECODE-UNIVERSAL-TIME GET-DECODED-TIME ENCODE-UNIVERSAL-TIME) (("tree-equal") TREE-EQUAL) (("typep") TYPEP) (("upgraded-complex-part-type") UPGRADED-COMPLEX-PART-TYPE) (("write-sequence") WRITE-SEQUENCE)))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) + +;; MACROS + (IN-PACKAGE :CL) -(DOLIST (SYSTEM::FS (QUOTE ((("and") AND) (("assert") ASSERT) (("case") CASE CCASE ECASE TYPECASE CTYPECASE ETYPECASE) (("check-type") CHECK-TYPE) (("clos") DEFINE-METHOD-COMBINATION DEFGENERIC DEFMETHOD DEFCLASS DEFINE-CONDITION) (("compiler-macro") DEFINE-COMPILER-MACRO) (("cond") COND) (("count") VECTOR-COUNT-IF LIST-COUNT-IF) (("define-modify-macro") DEFINE-MODIFY-MACRO) (("define-symbol-macro") DEFINE-SYMBOL-MACRO) (("defmacro") DEFMACRO) (("defpackage") DEFPACKAGE) (("defstruct") DEFSTRUCT) (("deftype") DEFTYPE) (("destructuring-bind") DESTRUCTURING-BIND) (("do-all-symbols") DO-ALL-SYMBOLS) (("do-external-symbols") DO-EXTERNAL-SYMBOLS) (("do-symbols") DO-SYMBOLS) (("do") DO DO*) (("dolist") DOLIST) (("dotimes") DOTIMES) (("error") IGNORE-ERRORS) (("format") FORMATTER) (("late-setf") DEFINE-SETF-EXPANDER) (("loop") LOOP-FINISH) (("mismatch") WITH-START-END) (("multiple-value-bind") MULTIPLE-VALUE-BIND) (("multiple-value-list") MULTIPLE-VALUE-LIST) (("multiple-value-setq") MULTIPLE-VALUE-SETQ) (("nth-value") NTH-VALUE) (("or") OR) (("pprint") PPRINT-LOGICAL-BLOCK) (("print-unreadable-object") PRINT-UNREADABLE-OBJECT) (("proclaim") DECLAIM) (("prog") PROG PROG*) (("psetf") PSETF) (("remf") REMF) (("rotatef") ROTATEF) (("setf") SETF) (("shiftf") SHIFTF) (("step") STEP) (("sublis") NSUBLIS-MACRO) (("substitute") REAL-COUNT SUBST-DISPATCH) (("trace") TRACE UNTRACE) (("with-accessors") WITH-ACCESSORS) (("with-hash-table-iterator") WITH-HASH-TABLE-ITERATOR) (("with-input-from-string") WITH-INPUT-FROM-STRING) (("with-open-file") WITH-OPEN-FILE) (("with-output-to-string") WITH-OUTPUT-TO-STRING) (("with-package-iterator") WITH-PACKAGE-ITERATOR) (("with-slots") WITH-SLOTS) (("with-standard-io-syntax") WITH-STANDARD-IO-SYNTAX)))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(DOLIST (SYSTEM::FS (QUOTE ((("and") AND) (("assert") ASSERT) (("case") CASE CCASE ECASE TYPECASE CTYPECASE ETYPECASE) (("check-type") CHECK-TYPE) (("clos") DEFINE-METHOD-COMBINATION DEFGENERIC DEFMETHOD DEFCLASS DEFINE-CONDITION) (("compiler-macro") DEFINE-COMPILER-MACRO) (("compiler-pass2") WITH-COMPILATION-UNIT) (("cond") COND) (("count") VECTOR-COUNT-IF LIST-COUNT-IF) (("define-modify-macro") DEFINE-MODIFY-MACRO) (("define-symbol-macro") DEFINE-SYMBOL-MACRO) (("defmacro") DEFMACRO) (("defpackage") DEFPACKAGE) (("defstruct") DEFSTRUCT) (("deftype") DEFTYPE) (("destructuring-bind") DESTRUCTURING-BIND) (("do-all-symbols") DO-ALL-SYMBOLS) (("do-external-symbols") DO-EXTERNAL-SYMBOLS) (("do-symbols") DO-SYMBOLS) (("do") DO DO*) (("dolist") DOLIST) (("dotimes") DOTIMES) (("error") IGNORE-ERRORS) (("format") FORMATTER) (("late-setf") DEFINE-SETF-EXPANDER) (("loop") LOOP LOOP-FINISH) (("mismatch") WITH-START-END) (("multiple-value-bind") MULTIPLE-VALUE-BIND) (("multiple-value-list") MULTIPLE-VALUE-LIST) (("multiple-value-setq") MULTIPLE-VALUE-SETQ) (("nth-value") NTH-VALUE) (("or") OR) (("pprint") PPRINT-LOGICAL-BLOCK) (("print-unreadable-object") PRINT-UNREADABLE-OBJECT) (("proclaim") DECLAIM) (("prog") PROG PROG*) (("psetf") PSETF) (("remf") REMF) (("rotatef") ROTATEF) (("setf") SETF) (("shiftf") SHIFTF) (("step") STEP) (("sublis") NSUBLIS-MACRO) (("substitute") REAL-COUNT SUBST-DISPATCH) (("trace") TRACE UNTRACE) (("with-accessors") WITH-ACCESSORS) (("with-hash-table-iterator") WITH-HASH-TABLE-ITERATOR) (("with-input-from-string") WITH-INPUT-FROM-STRING) (("with-open-file") WITH-OPEN-FILE) (("with-output-to-string") WITH-OUTPUT-TO-STRING) (("with-package-iterator") WITH-PACKAGE-ITERATOR) (("with-slots") WITH-SLOTS) (("with-standard-io-syntax") WITH-STANDARD-IO-SYNTAX)))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) From ehuelsmann at common-lisp.net Sat Aug 18 11:05:38 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 18 Aug 2012 04:05:38 -0700 Subject: [armedbear-cvs] r14119 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 18 04:05:37 2012 New Revision: 14119 Log: Revert r14107: r14118 meets the compilation requirement. Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Sat Aug 18 04:04:18 2012 (r14118) +++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Sat Aug 18 04:05:37 2012 (r14119) @@ -299,7 +299,6 @@ (load (do-compile "ldb.lisp")) (load (do-compile "destructuring-bind.lisp")) (load (do-compile "asdf.lisp")) - (load (do-compile "socket.lisp")) ;; But not for these. (mapc #'do-compile '("abcl-contrib.lisp" "adjoin.lisp" @@ -417,6 +416,7 @@ "sets.lisp" "shiftf.lisp" "signal.lisp" + "socket.lisp" "sort.lisp" "step.lisp" "strings.lisp" From ehuelsmann at common-lisp.net Sat Aug 18 11:06:14 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 18 Aug 2012 04:06:14 -0700 Subject: [armedbear-cvs] r14120 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 18 04:06:14 2012 New Revision: 14120 Log: Move profiler exports to profiler.lisp. Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp trunk/abcl/src/org/armedbear/lisp/profiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Sat Aug 18 04:05:37 2012 (r14119) +++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Sat Aug 18 04:06:14 2012 (r14120) @@ -52,10 +52,6 @@ (export 'concatenate-to-string '#:system) -;; Profiler. -(in-package "PROFILER") -(export '(*granularity* show-call-counts show-hot-counts with-profiling)) - ;; Extensions. (in-package "EXTENSIONS") (export 'simple-search) Modified: trunk/abcl/src/org/armedbear/lisp/profiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/profiler.lisp Sat Aug 18 04:05:37 2012 (r14119) +++ trunk/abcl/src/org/armedbear/lisp/profiler.lisp Sat Aug 18 04:06:14 2012 (r14120) @@ -31,7 +31,8 @@ (in-package #:profiler) -(export '(*hidden-functions*)) +(export '(*hidden-functions* *granularity* + show-call-counts show-hot-counts with-profiling)) (require '#:clos) (require '#:format) From ehuelsmann at common-lisp.net Sat Aug 18 11:37:35 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 18 Aug 2012 04:37:35 -0700 Subject: [armedbear-cvs] r14121 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 18 04:37:34 2012 New Revision: 14121 Log: Move exports from autoloads.lisp to the respective defining files. Also, delete JVM-COMPILE-PACKAGE, which hasn't been used in our sources for ages and doesn't seem to serve an external purpose. Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp trunk/abcl/src/org/armedbear/lisp/aver.lisp trunk/abcl/src/org/armedbear/lisp/compile-file.lisp trunk/abcl/src/org/armedbear/lisp/compile-system.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/describe-compiler-policy.lisp trunk/abcl/src/org/armedbear/lisp/gui.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp trunk/abcl/src/org/armedbear/lisp/precompiler.lisp trunk/abcl/src/org/armedbear/lisp/run-program.lisp trunk/abcl/src/org/armedbear/lisp/run-shell-command.lisp trunk/abcl/src/org/armedbear/lisp/search.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Sat Aug 18 04:06:14 2012 (r14120) +++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Sat Aug 18 04:37:34 2012 (r14121) @@ -54,47 +54,13 @@ ;; Extensions. (in-package "EXTENSIONS") -(export 'simple-search) -(export 'run-shell-command) -(autoload 'run-shell-command) -(export 'run-program) -(autoload 'run-program) -(export 'process) ;; Not a function, but a DEFSTRUCT -(export 'process-p) -(autoload 'process-p "run-program") -(export 'process-input) + +;; due to the macro-expansion of DEFSTRUCT, +;; slot accessors aren't being "detected" (autoload 'process-input "run-program") -(export 'process-output) (autoload 'process-output "run-program") -(export 'process-error) (autoload 'process-error "run-program") -(export 'process-alive-p) -(autoload 'process-alive-p "run-program") -(export 'process-wait) -(autoload 'process-wait "run-program") -(export 'process-exit-code) -(autoload 'process-exit-code "run-program") -(export 'process-kill) -(autoload 'process-kill "run-program") - - -(export '(grovel-java-definitions compile-system)) -(export 'aver) -(export 'collect) -(export 'compile-file-if-needed) -(export 'describe-compiler-policy) -(export 'macroexpand-all) - -(export '*gui-backend*) -(export 'init-gui) -(export 'make-dialog-prompt-stream) - -;; JVM compiler. -(in-package "JVM") -(export '(jvm-compile-package)) -(in-package "LISP") -(export 'compiler-let) (in-package "SYSTEM") Modified: trunk/abcl/src/org/armedbear/lisp/aver.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/aver.lisp Sat Aug 18 04:06:14 2012 (r14120) +++ trunk/abcl/src/org/armedbear/lisp/aver.lisp Sat Aug 18 04:37:34 2012 (r14121) @@ -33,6 +33,8 @@ (in-package "SYSTEM") +(export 'aver) + (defun %failed-aver (expr-as-string) (error 'simple-error :format-control "Failed AVER: ~S" Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sat Aug 18 04:06:14 2012 (r14120) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sat Aug 18 04:37:34 2012 (r14121) @@ -33,6 +33,9 @@ (require "COMPILER-PASS2") + +(export 'compile-file-if-needed) + (defvar *fbound-names*) (defvar *class-number*) Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Sat Aug 18 04:06:14 2012 (r14120) +++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Sat Aug 18 04:37:34 2012 (r14121) @@ -35,6 +35,9 @@ (require "COLLECT") (require "COMPILE-FILE") +(export '(grovel-java-definitions-in-file compile-system)) + + (defun check-lisp-home () (loop (cond ((and *lisp-home* Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Aug 18 04:06:14 2012 (r14120) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Aug 18 04:37:34 2012 (r14121) @@ -7558,16 +7558,6 @@ -(defun jvm-compile-package (package-designator) - (let ((pkg (if (packagep package-designator) - package-designator - (find-package package-designator)))) - (dolist (sym (sys::package-symbols pkg)) - (when (fboundp sym) - (unless (or (special-operator-p sym) (macro-function sym)) - (jvm-compile sym))))) - t) - (defun initialize-p2-handlers () (mapc #'install-p2-handler '(declare multiple-value-call Modified: trunk/abcl/src/org/armedbear/lisp/describe-compiler-policy.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/describe-compiler-policy.lisp Sat Aug 18 04:06:14 2012 (r14120) +++ trunk/abcl/src/org/armedbear/lisp/describe-compiler-policy.lisp Sat Aug 18 04:37:34 2012 (r14121) @@ -30,6 +30,8 @@ (in-package "SYSTEM") +(export 'describe-compiler-policy) + (defun describe-compiler-policy () (format t "~&; Compiler policy: safety ~D, space ~D, speed ~D, debug ~D~%" *safety* *space* *speed* *debug*) Modified: trunk/abcl/src/org/armedbear/lisp/gui.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/gui.lisp Sat Aug 18 04:06:14 2012 (r14120) +++ trunk/abcl/src/org/armedbear/lisp/gui.lisp Sat Aug 18 04:37:34 2012 (r14121) @@ -2,6 +2,9 @@ (require :java) +(export '(*gui-backend* init-gui make-dialog-prompt-stream)) + + (defvar *gui-backend* :swing) (defun init-gui () @@ -15,8 +18,8 @@ (defmethod %make-dialog-prompt-stream ((gui-backend (eql :swing))) (java:jnew (java:jconstructor - "org.armedbear.lisp.java.swing.SwingDialogPromptStream"))) + "org.armedbear.lisp.java.swing.SwingDialogPromptStream"))) (defmethod %make-dialog-prompt-stream ((gui-backend (eql :awt))) (java:jnew (java:jconstructor - "org.armedbear.lisp.java.awt.AwtDialogPromptStream"))) \ No newline at end of file + "org.armedbear.lisp.java.awt.AwtDialogPromptStream"))) Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp Sat Aug 18 04:06:14 2012 (r14120) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Sat Aug 18 04:37:34 2012 (r14121) @@ -31,8 +31,7 @@ (in-package "JVM") -(export '(compile-defun *catch-errors* jvm-compile-package - derive-compiler-type)) +(export '(compile-defun *catch-errors* derive-compiler-type)) (require "JVM-CLASS-FILE") Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Sat Aug 18 04:06:14 2012 (r14120) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Sat Aug 18 04:37:34 2012 (r14121) @@ -1050,11 +1050,16 @@ (export '(precompile-form)) (in-package #:ext) + +(export 'macroexpand-all) + (defun macroexpand-all (form &optional env) (precompiler:precompile-form form t env)) (in-package #:lisp) +(export '(compiler-let)) + (defmacro compiler-let (bindings &body forms &environment env) (let ((bindings (mapcar #'(lambda (binding) (if (atom binding) (list binding) binding)) Modified: trunk/abcl/src/org/armedbear/lisp/run-program.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/run-program.lisp Sat Aug 18 04:06:14 2012 (r14120) +++ trunk/abcl/src/org/armedbear/lisp/run-program.lisp Sat Aug 18 04:37:34 2012 (r14121) @@ -33,6 +33,10 @@ (require "JAVA") +(export '(run-program process process-p process-input process-output + process-error process-alive-p process-wait process-exit-code + process-kill)) + ;;; Vaguely inspired by sb-ext:run-program in SBCL. ;;; ;;; See . Modified: trunk/abcl/src/org/armedbear/lisp/run-shell-command.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/run-shell-command.lisp Sat Aug 18 04:06:14 2012 (r14120) +++ trunk/abcl/src/org/armedbear/lisp/run-shell-command.lisp Sat Aug 18 04:37:34 2012 (r14121) @@ -31,5 +31,7 @@ (in-package "SYSTEM") +(export '(run-shell-command)) + (defun run-shell-command (command &key directory (output *standard-output*)) (%run-shell-command command directory output)) Modified: trunk/abcl/src/org/armedbear/lisp/search.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/search.lisp Sat Aug 18 04:06:14 2012 (r14120) +++ trunk/abcl/src/org/armedbear/lisp/search.lisp Sat Aug 18 04:37:34 2012 (r14121) @@ -33,6 +33,9 @@ (require "EXTENSIBLE-SEQUENCES-BASE") +(export '(simple-search)) + + ;; From CMUCL. (eval-when (:compile-toplevel :execute) From ehuelsmann at common-lisp.net Sat Aug 18 12:32:39 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 18 Aug 2012 05:32:39 -0700 Subject: [armedbear-cvs] r14122 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 18 05:32:39 2012 New Revision: 14122 Log: Update autoloads-gen.lisp to match r14121. Modified: trunk/abcl/src/org/armedbear/lisp/autoloads-gen.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads-gen.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads-gen.lisp Sat Aug 18 04:37:34 2012 (r14121) +++ trunk/abcl/src/org/armedbear/lisp/autoloads-gen.lisp Sat Aug 18 05:32:39 2012 (r14122) @@ -72,7 +72,7 @@ ;; EXPORTS (IN-PACKAGE :PROFILER) -(EXPORT (QUOTE (*HIDDEN-FUNCTIONS*))) +(EXPORT (QUOTE (WITH-PROFILING SHOW-HOT-COUNTS SHOW-CALL-COUNTS *GRANULARITY* *HIDDEN-FUNCTIONS*))) ;; FUNCTIONS @@ -98,12 +98,12 @@ (DOLIST (SYSTEM::FS (QUOTE ((("java") CHAIN JMETHOD-LET) (("runtime-class") DEFINE-JAVA-CLASS)))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) ;; EXPORTS (IN-PACKAGE :JVM) -(EXPORT (QUOTE (DERIVE-COMPILER-TYPE JVM-COMPILE-PACKAGE *CATCH-ERRORS* COMPILE-DEFUN))) +(EXPORT (QUOTE (DERIVE-COMPILER-TYPE *CATCH-ERRORS* COMPILE-DEFUN))) ;; FUNCTIONS (IN-PACKAGE :JVM) -(DOLIST (SYSTEM::FS (QUOTE ((("compiler-pass1") GENERATE-INLINE-EXPANSION PARSE-LAMBDA-LIST MATCH-LAMBDA-LIST MATCH-KEYWORD-AND-REST-ARGS EXPAND-FUNCTION-CALL-INLINE PROCESS-DECLARATIONS-FOR-VARS CHECK-NAME P1-BODY P1-DEFAULT P1-LET-VARS P1-LET*-VARS P1-LET/LET* P1-LOCALLY P1-M-V-B P1-BLOCK P1-CATCH P1-THREADS-SYNCHRONIZED-ON P1-UNWIND-PROTECT P1-RETURN-FROM P1-TAGBODY P1-GO SPLIT-DECLS REWRITE-AUX-VARS REWRITE-LAMBDA VALIDATE-FUNCTION-NAME CONSTRUCT-FLET/LABELS-FUNCTION P1-FLET P1-LABELS P1-FUNCALL P1-FUNCTION P1-LAMBDA P1-EVAL-WHEN P1-PROGV P1-QUOTE P1-SETQ P1-THE P1-TRULY-THE P1-THROW REWRITE-FUNCTION-CALL P1-FUNCTION-CALL %FUNCALL P1-VARIABLE-REFERENCE P1 INSTALL-P1-HANDLER INITIALIZE-P1-HANDLERS P1-COMPILAND) (("compiler-pass2") POOL-NAME POOL-NAME-AND-TYPE POOL-CLASS POOL-STRING POOL-FIELD POOL-METHOD POOL-INT POOL-FLOAT POOL-LONG POOL-DOUBLE ADD-EXCEPTION-HANDLER EMIT-PUSH-NIL EMIT-PUSH-NIL-SYMBOL EMIT-PUSH-T EMIT-PUSH-FALSE EMIT-PUSH-TRUE EMIT-PUSH-CONSTANT-INT EMIT-PUSH-CONSTANT-LONG EMIT-PUSH-CONSTANT-FLOAT EMIT-PUSH-CONSTANT-DOUBLE EMIT-DUP EMIT-SWAP EMIT-INVOKESTATIC PRETTY-JAVA-CLASS EMIT-INVOKEVIRTUAL EMIT-INVOKESPECIAL-INIT PRETTY-JAVA-TYPE EMIT-GETSTATIC EMIT-PUTSTATIC EMIT-GETFIELD EMIT-PUTFIELD EMIT-NEW EMIT-ANEWARRAY EMIT-CHECKCAST EMIT-INSTANCEOF TYPE-REPRESENTATION EMIT-UNBOX-BOOLEAN EMIT-UNBOX-CHARACTER CONVERT-REPRESENTATION COMMON-REPRESENTATION MAYBE-INITIALIZE-THREAD-VAR ENSURE-THREAD-VAR-INITIALIZED EMIT-PUSH-CURRENT-THREAD VARIABLE-LOCAL-P EMIT-LOAD-LOCAL-VARIABLE EMIT-PUSH-VARIABLE-NAME GENERATE-INSTANCEOF-TYPE-CHECK-FOR-VARIABLE FIND-TYPE-FOR-TYPE-CHECK GENERATE-TYPE-CHECK-FOR-VARIABLE MAYBE-GENERATE-TYPE-CHECK GENERATE-TYPE-CHECKS-FOR-VARIABLES GENERATE-ARG-COUNT-CHECK MAYBE-GENERATE-INTERRUPT-CHECK SINGLE-VALUED-P EMIT-CLEAR-VALUES MAYBE-EMIT-CLEAR-VALUES COMPILE-FORMS-AND-MAYBE-EMIT-CLEAR-VALUES LOAD-SAVED-OPERANDS SAVE-EXISTING-OPERANDS SAVE-OPERAND COMPILE-OPERAND EMIT-VARIABLE-OPERAND EMIT-REGISTER-OPERAND EMIT-THREAD-OPERAND EMIT-LOAD-EXTERNALIZED-OBJECT-OPERAND EMIT-UNBOX-FIXNUM EMIT-UNBOX-LONG EMIT-UNBOX-FLOAT EMIT-UNBOX-DOUBLE FIX-BOXING EMIT-MOVE-FROM-STACK EMIT-PUSH-REGISTER EMIT-INVOKE-METHOD CHECK-NUMBER-OF-ARGS CHECK-ARG-COUNT CHECK-MIN-ARGS EMIT-CONSTRUCTOR-LAMBDA-NAME EMIT-CONSTRUCTOR-LAMBDA-LIST EMIT-READ-FROM-STRING MAKE-CONSTRUCTOR MAKE-STATIC-INITIALIZER FINISH-CLASS DECLARE-FIELD SANITIZE SERIALIZE-INTEGER SERIALIZE-CHARACTER SERIALIZE-FLOAT SERIALIZE-DOUBLE SERIALIZE-STRING SERIALIZE-PACKAGE COMPILAND-EXTERNAL-CONSTANT-RESOURCE-NAME SERIALIZE-OBJECT SERIALIZE-SYMBOL EMIT-LOAD-EXTERNALIZED-OBJECT DECLARE-FUNCTION DECLARE-SETF-FUNCTION LOCAL-FUNCTION-CLASS-AND-FIELD DECLARE-LOCAL-FUNCTION DECLARE-OBJECT-AS-STRING DECLARE-LOAD-TIME-VALUE DECLARE-OBJECT COMPILE-CONSTANT INITIALIZE-UNARY-OPERATORS INSTALL-P2-HANDLER DEFINE-PREDICATE P2-PREDICATE COMPILE-FUNCTION-CALL-1 INITIALIZE-BINARY-OPERATORS COMPILE-BINARY-OPERATION COMPILE-FUNCTION-CALL-2 FIXNUM-OR-UNBOXED-VARIABLE-P EMIT-PUSH-INT EMIT-PUSH-LONG P2-EQ/NEQ EMIT-IFNE-FOR-EQL P2-EQL P2-MEMQ P2-MEMQL P2-GENSYM P2-GET P2-GETF P2-GETHASH P2-PUTHASH INLINE-OK PROCESS-ARGS EMIT-CALL-EXECUTE EMIT-CALL-THREAD-EXECUTE COMPILE-FUNCTION-CALL COMPILE-CALL P2-FUNCALL DUPLICATE-CLOSURE-ARRAY EMIT-LOAD-LOCAL-FUNCTION COMPILE-LOCAL-FUNCTION-CALL EMIT-NUMERIC-COMPARISON P2-NUMERIC-COMPARISON P2-TEST-HANDLER INITIALIZE-P2-TEST-HANDLERS NEGATE-JUMP-CONDITION EMIT-TEST-JUMP P2-TEST-PREDICATE P2-TEST-INSTANCEOF-PREDICATE P2-TEST-BIT-VECTOR-P P2-TEST-CHARACTERP P2-TEST-CONSTANTP P2-TEST-ENDP P2-TEST-EVENP P2-TEST-ODDP P2-TEST-FLOATP P2-TEST-INTEGERP P2-TEST-LISTP P2-TEST-MINUSP P2-TEST-PLUSP P2-TEST-ZEROP P2-TEST-NUMBERP P2-TEST-PACKAGEP P2-TEST-RATIONALP P2-TEST-REALP P2-TEST-SPECIAL-OPERATOR-P P2-TEST-SPECIAL-VARIABLE-P P2-TEST-SYMBOLP P2-TEST-CONSP P2-TEST-ATOM P2-TEST-FIXNUMP P2-TEST-STRINGP P2-TEST-VECTORP P2-TEST-SIMPLE-VECTOR-P COMPILE-TEST-FORM P2-TEST-NOT/NULL P2-TEST-CHAR= P2-TEST-EQ P2-TEST-OR P2-TEST-AND P2-TEST-NEQ P2-TEST-EQL P2-TEST-EQUALITY P2-TEST-SIMPLE-TYPEP P2-TEST-MEMQ P2-TEST-MEMQL P2-TEST-/= P2-TEST-NUMERIC-COMPARISON P2-IF COMPILE-MULTIPLE-VALUE-LIST COMPILE-MULTIPLE-VALUE-PROG1 COMPILE-MULTIPLE-VALUE-CALL UNUSED-VARIABLE CHECK-FOR-UNUSED-VARIABLES EMIT-NEW-CLOSURE-BINDING COMPILE-BINDING COMPILE-PROGN-BODY RESTORE-DYNAMIC-ENVIRONMENT SAVE-DYNAMIC-ENVIRONMENT P2-M-V-B-NODE PROPAGATE-VARS DERIVE-VARIABLE-REPRESENTATION ALLOCATE-VARIABLE-REGISTER EMIT-MOVE-TO-VARIABLE EMIT-PUSH-VARIABLE P2-LET-BINDINGS P2-LET*-BINDINGS P2-LET/LET*-NODE P2-LOCALLY-NODE P2-TAGBODY-NODE P2-GO P2-ATOM P2-INSTANCEOF-PREDICATE P2-BIT-VECTOR-P P2-CHARACTERP P2-CONSP P2-FIXNUMP P2-PACKAGEP P2-READTABLEP P2-SIMPLE-VECTOR-P P2-STRINGP P2-SYMBOLP P2-VECTORP P2-COERCE-TO-FUNCTION P2-BLOCK-NODE P2-RETURN-FROM EMIT-CAR/CDR P2-CAR P2-CDR P2-CONS COMPILE-PROGN P2-EVAL-WHEN P2-LOAD-TIME-VALUE P2-PROGV-NODE P2-QUOTE P2-RPLACD P2-SET-CAR/CDR COMPILE-DECLARE COMPILE-LOCAL-FUNCTION P2-FLET-NODE P2-LABELS-NODE P2-LAMBDA P2-FUNCTION P2-ASH P2-LOGAND P2-LOGIOR P2-LOGXOR P2-LOGNOT P2-%LDB P2-MOD P2-ZEROP P2-FIND-CLASS P2-VECTOR-PUSH-EXTEND P2-STD-SLOT-VALUE P2-SET-STD-SLOT-VALUE P2-STREAM-ELEMENT-TYPE P2-WRITE-8-BITS P2-READ-LINE DERIVE-TYPE-AREF DERIVE-TYPE-FIXNUMP DERIVE-TYPE-SETQ DERIVE-TYPE-LOGIOR/LOGXOR DERIVE-TYPE-LOGAND DERIVE-TYPE-LOGNOT DERIVE-TYPE-MOD DERIVE-TYPE-COERCE DERIVE-TYPE-COPY-SEQ DERIVE-TYPE-INTEGER-LENGTH DERIVE-TYPE-%LDB DERIVE-INTEGER-TYPE DERIVE-TYPE-NUMERIC-OP DERIVE-COMPILER-TYPES DERIVE-TYPE-MINUS DERIVE-TYPE-PLUS DERIVE-TYPE-TIMES DERIVE-TYPE-MAX DERIVE-TYPE-MIN DERIVE-TYPE-READ-CHAR DERIVE-TYPE-ASH DERIVE-TYPE DERIVE-COMPILER-TYPE P2-DELETE P2-LENGTH CONS-FOR-LIST/LIST* P2-LIST P2-LIST* COMPILE-NTH P2-TIMES P2-MIN/MAX P2-PLUS P2-MINUS P2-CHAR/SCHAR P2-SET-CHAR/SCHAR P2-SVREF P2-SVSET P2-TRUNCATE P2-ELT P2-AREF P2-ASET P2-STRUCTURE-REF P2-STRUCTURE-SET P2-NOT/NULL P2-NTHCDR P2-AND P2-OR P2-VALUES COMPILE-SPECIAL-REFERENCE COMPILE-VAR-REF P2-SET P2-SETQ P2-SXHASH P2-SYMBOL-NAME P2-SYMBOL-PACKAGE P2-SYMBOL-VALUE GENERATE-INSTANCEOF-TYPE-CHECK-FOR-VALUE GENERATE-TYPE-CHECK-FOR-VALUE P2-THE P2-TRULY-THE P2-CHAR-CODE P2-JAVA-JCLASS P2-JAVA-JCONSTRUCTOR P2-JAVA-JMETHOD P2-CHAR= P2-THREADS-SYNCHRONIZED-ON P2-CATCH-NODE P2-THROW P2-UNWIND-PROTECT-NODE COMPILE-FORM P2-COMPILAND-PROCESS-TYPE-DECLARATIONS P2-COMPILAND-UNBOX-VARIABLE ASSIGN-FIELD-NAME P2-COMPILAND COMPILE-TO-JVM-CLASS P2-WITH-INLINE-CODE COMPILE-1 MAKE-COMPILER-ERROR-FORM COMPILE-DEFUN NOTE-ERROR-CONTEXT HANDLE-WARNING HANDLE-COMPILER-ERROR %WITH-COMPILATION-UNIT %JVM-COMPILE JVM-COMPILE JVM-COMPILE-PACKAGE INITIALIZE-P2-HANDLERS) (("dump-class") READ-U1 READ-U2 READ-U4 LOOKUP-UTF8 READ-CONSTANT-POOL-ENTRY DUMP-CODE DUMP-CODE-ATTRIBUTE DUMP-EXCEPTIONS READ-ATTRIBUTE READ-INFO DUMP-CLASS) (("jvm-class-file") MAP-PRIMITIVE-TYPE PRETTY-CLASS PRETTY-TYPE %MAKE-JVM-CLASS-NAME JVM-CLASS-NAME-P MAKE-JVM-CLASS-NAME CLASS-ARRAY INTERNAL-FIELD-TYPE INTERNAL-FIELD-REF DESCRIPTOR DESCRIPTOR-STACK-EFFECT MAKE-POOL POOL-P MATCHING-INDEX-P FIND-POOL-ENTRY MAKE-CONSTANT CONSTANT-P PRINT-POOL-CONSTANT MAKE-CONSTANT-CLASS CONSTANT-CLASS-P %MAKE-CONSTANT-MEMBER-REF CONSTANT-MEMBER-REF-P MAKE-CONSTANT-FIELD-REF MAKE-CONSTANT-METHOD-REF MAKE-CONSTANT-INTERFACE-METHOD-REF MAKE-CONSTANT-STRING CONSTANT-STRING-P %MAKE-CONSTANT-FLOAT/INT CONSTANT-FLOAT/INT-P MAKE-CONSTANT-FLOAT MAKE-CONSTANT-INT %MAKE-CONSTANT-DOUBLE/LONG CONSTANT-DOUBLE/LONG-P MAKE-CONSTANT-DOUBLE MAKE-CONSTANT-LONG MAKE-CONSTANT-NAME/TYPE CONSTANT-NAME/TYPE-P PARSE-DESCRIPTOR MAKE-CONSTANT-UTF8 CONSTANT-UTF8-P POOL-ADD-CLASS POOL-ADD-FIELD-REF POOL-ADD-METHOD-REF POOL-ADD-INTERFACE-METHOD-REF POOL-ADD-STRING POOL-ADD-INT POOL-ADD-FLOAT POOL-ADD-LONG POOL-ADD-DOUBLE POOL-ADD-NAME/TYPE POOL-ADD-UTF8 MAKE-CLASS-FILE CLASS-FILE-P MAKE-CLASS-INTERFACE-FILE CLASS-ADD-FIELD CLASS-FIELD CLASS-ADD-METHOD CLASS-METHODS-BY-NAME CLASS-METHOD CLASS-REMOVE-METHOD CLASS-ADD-ATTRIBUTE CLASS-ADD-SUPERINTERFACE CLASS-ATTRIBUTE FINALIZE-INTERFACES FINALIZE-CLASS-FILE WRITE-U1 WRITE-U2 WRITE-U4 WRITE-S4 WRITE-ASCII WRITE-UTF8 WRITE-CLASS-FILE WRITE-CONSTANTS PRINT-ENTRY MAP-FLAGS %MAKE-FIELD FIELD-P MAKE-FIELD FIELD-ADD-ATTRIBUTE FIELD-ATTRIBUTE FINALIZE-FIELD WRITE-FIELD %MAKE-JVM-METHOD JVM-METHOD-P MAP-METHOD-NAME MAKE-JVM-METHOD METHOD-ADD-ATTRIBUTE METHOD-ADD-CODE METHOD-ENSURE-CODE METHOD-ATTRIBUTE FINALIZE-METHOD WRITE-METHOD MAKE-ATTRIBUTE ATTRIBUTE-P FINALIZE-ATTRIBUTES WRITE-ATTRIBUTES %MAKE-CODE-ATTRIBUTE CODE-ATTRIBUTE-P CODE-LABEL-OFFSET FINALIZE-CODE-ATTRIBUTE WRITE-CODE-ATTRIBUTE MAKE-CODE-ATTRIBUTE CODE-ADD-ATTRIBUTE CODE-ATTRIBUTE CODE-ADD-EXCEPTION-HANDLER MAKE-EXCEPTION EXCEPTION-P MAKE-CONSTANT-VALUE-ATTRIBUTE CONSTANT-VALUE-ATTRIBUTE-P MAKE-CHECKED-EXCEPTIONS-ATTRIBUTE CHECKED-EXCEPTIONS-ATTRIBUTE-P FINALIZE-CHECKED-EXCEPTIONS WRITE-CHECKED-EXCEPTIONS MAKE-DEPRECATED-ATTRIBUTE DEPRECATED-ATTRIBUTE-P SAVE-CODE-SPECIALS RESTORE-CODE-SPECIALS MAKE-SOURCE-FILE-ATTRIBUTE SOURCE-FILE-ATTRIBUTE-P FINALIZE-SOURCE-FILE WRITE-SOURCE-FILE MAKE-SYNTHETIC-ATTRIBUTE SYNTHETIC-ATTRIBUTE-P MAKE-LINE-NUMBERS-ATTRIBUTE LINE-NUMBERS-ATTRIBUTE-P MAKE-LINE-NUMBER LINE-NUMBER-P FINALIZE-LINE-NUMBERS WRITE-LINE-NUMBERS LINE-NUMBERS-ADD-LINE MAKE-LOCAL-VARIABLES-ATTRIBUTE LOCAL-VARIABLES-ATTRIBUTE-P MAKE-LOCAL-VARIABLE LOCAL-VARIABLE-P FINALIZE-LOCAL-VARIABLES WRITE-LOCAL-VARIABLES MAKE-ANNOTATIONS-ATTRIBUTE ANNOTATIONS-ATTRIBUTE-P MAKE-ANNOTATION ANNOTATION-P MAKE-ANNOTATION-ELEMENT ANNOTATION-ELEMENT-P MAKE-PRIMITIVE-OR-STRING-ANNOTATION-ELEMENT PRIMITIVE-OR-STRING-ANNOTATION-ELEMENT-P MAKE-ENUM-VALUE-ANNOTATION-ELEMENT ENUM-VALUE-ANNOTATION-ELEMENT-P MAKE-ANNOTATION-VALUE-ANNOTATION-ELEMENT ANNOTATION-VALUE-ANNOTATION-ELEMENT-P MAKE-ARRAY-ANNOTATION-ELEMENT ARRAY-ANNOTATION-ELEMENT-P MAKE-RUNTIME-VISIBLE-ANNOTATIONS-ATTRIBUTE RUNTIME-VISIBLE-ANNOTATIONS-ATTRIBUTE-P FINALIZE-ANNOTATIONS FINALIZE-ANNOTATION FINALIZE-ANNOTATION-ELEMENT WRITE-ANNOTATIONS WRITE-ANNOTATION WRITE-ANNOTATION-ELEMENT) (("jvm-instructions") U2 S1 S2 MAKE-JVM-OPCODE JVM-OPCODE-P %DEFINE-OPCODE OPCODE-NAME OPCODE-NUMBER OPCODE-SIZE OPCODE-STACK-EFFECT OPCODE-ARGS-SPEC %MAKE-INSTRUCTION INSTRUCTION-P MAKE-INSTRUCTION PRINT-INSTRUCTION INSTRUCTION-LABEL INST %%EMIT %EMIT LABEL ALOAD ASTORE BRANCH-P UNCONDITIONAL-CONTROL-TRANSFER-P LABEL-P FORMAT-INSTRUCTION-ARGS PRINT-CODE PRINT-CODE2 EXPAND-VIRTUAL-INSTRUCTIONS UNSUPPORTED-OPCODE INITIALIZE-RESOLVERS LOAD/STORE-RESOLVER RESOLVE-INSTRUCTION RESOLVE-INSTRUCTIONS ANALYZE-STACK-PATH ANALYZE-STACK ANALYZE-LOCALS DELETE-UNUSED-LABELS DELETE-UNREACHABLE-CODE LABEL-TARGET-INSTRUCTIONS OPTIMIZE-JUMPS OPTIMIZE-INSTRUCTION-SEQUENCES OPTIMIZE-CODE CODE-BYTES FINALIZE-CODE) (("jvm") INVOKE-CALLBACKS %MAKE-ABCL-CLASS-FILE ABCL-CLASS-FILE-P CLASS-NAME-FROM-FILESPEC MAKE-UNIQUE-CLASS-NAME MAKE-ABCL-CLASS-FILE MAKE-COMPILAND COMPILAND-P COMPILAND-SINGLE-VALUED-P DUMP-1-VARIABLE DUMP-VARIABLES MAKE-VARIABLE VARIABLE-P MAKE-VAR-REF VAR-REF-P UNBOXED-FIXNUM-VARIABLE FIND-VARIABLE FIND-VISIBLE-VARIABLE REPRESENTATION-SIZE ALLOCATE-REGISTER MAKE-LOCAL-FUNCTION LOCAL-FUNCTION-P FIND-LOCAL-FUNCTION MAKE-NODE NODE-P ADD-NODE-CHILD MAKE-CONTROL-TRANSFERRING-NODE CONTROL-TRANSFERRING-NODE-P %MAKE-TAGBODY-NODE TAGBODY-NODE-P MAKE-TAGBODY-NODE %MAKE-CATCH-NODE CATCH-NODE-P MAKE-CATCH-NODE %MAKE-BLOCK-NODE BLOCK-NODE-P MAKE-BLOCK-NODE %MAKE-JUMP-NODE JUMP-NODE-P MAKE-JUMP-NODE MAKE-BINDING-NODE BINDING-NODE-P %MAKE-LET/LET*-NODE LET/LET*-NODE-P MAKE-LET/LET*-NODE %MAKE-FLET-NODE FLET-NODE-P MAKE-FLET-NODE %MAKE-LABELS-NODE LABELS-NODE-P MAKE-LABELS-NODE %MAKE-M-V-B-NODE M-V-B-NODE-P MAKE-M-V-B-NODE %MAKE-PROGV-NODE PROGV-NODE-P MAKE-PROGV-NODE %MAKE-LOCALLY-NODE LOCALLY-NODE-P MAKE-LOCALLY-NODE %MAKE-PROTECTED-NODE PROTECTED-NODE-P MAKE-PROTECTED-NODE %MAKE-UNWIND-PROTECT-NODE UNWIND-PROTECT-NODE-P MAKE-UNWIND-PROTECT-NODE %MAKE-SYNCHRONIZED-NODE SYNCHRONIZED-NODE-P MAKE-SYNCHRONIZED-NODE FIND-BLOCK %FIND-ENCLOSED-BLOCKS FIND-ENCLOSED-BLOCKS SOME-NESTED-BLOCK NODE-CONSTANT-P BLOCK-REQUIRES-NON-LOCAL-EXIT-P NODE-OPSTACK-UNSAFE-P BLOCK-CREATES-RUNTIME-BINDINGS-P ENCLOSED-BY-RUNTIME-BINDINGS-CREATING-BLOCK-P ENCLOSED-BY-PROTECTED-BLOCK-P ENCLOSED-BY-ENVIRONMENT-SETTING-BLOCK-P ENVIRONMENT-REGISTER-TO-RESTORE MAKE-TAG TAG-P FIND-TAG PROCESS-IGNORE/IGNORABLE FINALIZE-GENERIC-FUNCTIONS) (("runtime-class") EMIT-INVOKESPECIAL PARSE-ANNOTATION PARSE-ANNOTATION-ELEMENT)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(DOLIST (SYSTEM::FS (QUOTE ((("compiler-pass1") GENERATE-INLINE-EXPANSION PARSE-LAMBDA-LIST MATCH-LAMBDA-LIST MATCH-KEYWORD-AND-REST-ARGS EXPAND-FUNCTION-CALL-INLINE PROCESS-DECLARATIONS-FOR-VARS CHECK-NAME P1-BODY P1-DEFAULT P1-LET-VARS P1-LET*-VARS P1-LET/LET* P1-LOCALLY P1-M-V-B P1-BLOCK P1-CATCH P1-THREADS-SYNCHRONIZED-ON P1-UNWIND-PROTECT P1-RETURN-FROM P1-TAGBODY P1-GO SPLIT-DECLS REWRITE-AUX-VARS REWRITE-LAMBDA VALIDATE-FUNCTION-NAME CONSTRUCT-FLET/LABELS-FUNCTION P1-FLET P1-LABELS P1-FUNCALL P1-FUNCTION P1-LAMBDA P1-EVAL-WHEN P1-PROGV P1-QUOTE P1-SETQ P1-THE P1-TRULY-THE P1-THROW REWRITE-FUNCTION-CALL P1-FUNCTION-CALL %FUNCALL P1-VARIABLE-REFERENCE P1 INSTALL-P1-HANDLER INITIALIZE-P1-HANDLERS P1-COMPILAND) (("compiler-pass2") POOL-NAME POOL-NAME-AND-TYPE POOL-CLASS POOL-STRING POOL-FIELD POOL-METHOD POOL-INT POOL-FLOAT POOL-LONG POOL-DOUBLE ADD-EXCEPTION-HANDLER EMIT-PUSH-NIL EMIT-PUSH-NIL-SYMBOL EMIT-PUSH-T EMIT-PUSH-FALSE EMIT-PUSH-TRUE EMIT-PUSH-CONSTANT-INT EMIT-PUSH-CONSTANT-LONG EMIT-PUSH-CONSTANT-FLOAT EMIT-PUSH-CONSTANT-DOUBLE EMIT-DUP EMIT-SWAP EMIT-INVOKESTATIC PRETTY-JAVA-CLASS EMIT-INVOKEVIRTUAL EMIT-INVOKESPECIAL-INIT PRETTY-JAVA-TYPE EMIT-GETSTATIC EMIT-PUTSTATIC EMIT-GETFIELD EMIT-PUTFIELD EMIT-NEW EMIT-ANEWARRAY EMIT-CHECKCAST EMIT-INSTANCEOF TYPE-REPRESENTATION EMIT-UNBOX-BOOLEAN EMIT-UNBOX-CHARACTER CONVERT-REPRESENTATION COMMON-REPRESENTATION MAYBE-INITIALIZE-THREAD-VAR ENSURE-THREAD-VAR-INITIALIZED EMIT-PUSH-CURRENT-THREAD VARIABLE-LOCAL-P EMIT-LOAD-LOCAL-VARIABLE EMIT-PUSH-VARIABLE-NAME GENERATE-INSTANCEOF-TYPE-CHECK-FOR-VARIABLE FIND-TYPE-FOR-TYPE-CHECK GENERATE-TYPE-CHECK-FOR-VARIABLE MAYBE-GENERATE-TYPE-CHECK GENERATE-TYPE-CHECKS-FOR-VARIABLES GENERATE-ARG-COUNT-CHECK MAYBE-GENERATE-INTERRUPT-CHECK SINGLE-VALUED-P EMIT-CLEAR-VALUES MAYBE-EMIT-CLEAR-VALUES COMPILE-FORMS-AND-MAYBE-EMIT-CLEAR-VALUES LOAD-SAVED-OPERANDS SAVE-EXISTING-OPERANDS SAVE-OPERAND COMPILE-OPERAND EMIT-VARIABLE-OPERAND EMIT-REGISTER-OPERAND EMIT-THREAD-OPERAND EMIT-LOAD-EXTERNALIZED-OBJECT-OPERAND EMIT-UNBOX-FIXNUM EMIT-UNBOX-LONG EMIT-UNBOX-FLOAT EMIT-UNBOX-DOUBLE FIX-BOXING EMIT-MOVE-FROM-STACK EMIT-PUSH-REGISTER EMIT-INVOKE-METHOD CHECK-NUMBER-OF-ARGS CHECK-ARG-COUNT CHECK-MIN-ARGS EMIT-CONSTRUCTOR-LAMBDA-NAME EMIT-CONSTRUCTOR-LAMBDA-LIST EMIT-READ-FROM-STRING MAKE-CONSTRUCTOR MAKE-STATIC-INITIALIZER FINISH-CLASS DECLARE-FIELD SANITIZE SERIALIZE-INTEGER SERIALIZE-CHARACTER SERIALIZE-FLOAT SERIALIZE-DOUBLE SERIALIZE-STRING SERIALIZE-PACKAGE COMPILAND-EXTERNAL-CONSTANT-RESOURCE-NAME SERIALIZE-OBJECT SERIALIZE-SYMBOL EMIT-LOAD-EXTERNALIZED-OBJECT DECLARE-FUNCTION DECLARE-SETF-FUNCTION LOCAL-FUNCTION-CLASS-AND-FIELD DECLARE-LOCAL-FUNCTION DECLARE-OBJECT-AS-STRING DECLARE-LOAD-TIME-VALUE DECLARE-OBJECT COMPILE-CONSTANT INITIALIZE-UNARY-OPERATORS INSTALL-P2-HANDLER DEFINE-PREDICATE P2-PREDICATE COMPILE-FUNCTION-CALL-1 INITIALIZE-BINARY-OPERATORS COMPILE-BINARY-OPERATION COMPILE-FUNCTION-CALL-2 FIXNUM-OR-UNBOXED-VARIABLE-P EMIT-PUSH-INT EMIT-PUSH-LONG P2-EQ/NEQ EMIT-IFNE-FOR-EQL P2-EQL P2-MEMQ P2-MEMQL P2-GENSYM P2-GET P2-GETF P2-GETHASH P2-PUTHASH INLINE-OK PROCESS-ARGS EMIT-CALL-EXECUTE EMIT-CALL-THREAD-EXECUTE COMPILE-FUNCTION-CALL COMPILE-CALL P2-FUNCALL DUPLICATE-CLOSURE-ARRAY EMIT-LOAD-LOCAL-FUNCTION COMPILE-LOCAL-FUNCTION-CALL EMIT-NUMERIC-COMPARISON P2-NUMERIC-COMPARISON P2-TEST-HANDLER INITIALIZE-P2-TEST-HANDLERS NEGATE-JUMP-CONDITION EMIT-TEST-JUMP P2-TEST-PREDICATE P2-TEST-INSTANCEOF-PREDICATE P2-TEST-BIT-VECTOR-P P2-TEST-CHARACTERP P2-TEST-CONSTANTP P2-TEST-ENDP P2-TEST-EVENP P2-TEST-ODDP P2-TEST-FLOATP P2-TEST-INTEGERP P2-TEST-LISTP P2-TEST-MINUSP P2-TEST-PLUSP P2-TEST-ZEROP P2-TEST-NUMBERP P2-TEST-PACKAGEP P2-TEST-RATIONALP P2-TEST-REALP P2-TEST-SPECIAL-OPERATOR-P P2-TEST-SPECIAL-VARIABLE-P P2-TEST-SYMBOLP P2-TEST-CONSP P2-TEST-ATOM P2-TEST-FIXNUMP P2-TEST-STRINGP P2-TEST-VECTORP P2-TEST-SIMPLE-VECTOR-P COMPILE-TEST-FORM P2-TEST-NOT/NULL P2-TEST-CHAR= P2-TEST-EQ P2-TEST-OR P2-TEST-AND P2-TEST-NEQ P2-TEST-EQL P2-TEST-EQUALITY P2-TEST-SIMPLE-TYPEP P2-TEST-MEMQ P2-TEST-MEMQL P2-TEST-/= P2-TEST-NUMERIC-COMPARISON P2-IF COMPILE-MULTIPLE-VALUE-LIST COMPILE-MULTIPLE-VALUE-PROG1 COMPILE-MULTIPLE-VALUE-CALL UNUSED-VARIABLE CHECK-FOR-UNUSED-VARIABLES EMIT-NEW-CLOSURE-BINDING COMPILE-BINDING COMPILE-PROGN-BODY RESTORE-DYNAMIC-ENVIRONMENT SAVE-DYNAMIC-ENVIRONMENT P2-M-V-B-NODE PROPAGATE-VARS DERIVE-VARIABLE-REPRESENTATION ALLOCATE-VARIABLE-REGISTER EMIT-MOVE-TO-VARIABLE EMIT-PUSH-VARIABLE P2-LET-BINDINGS P2-LET*-BINDINGS P2-LET/LET*-NODE P2-LOCALLY-NODE P2-TAGBODY-NODE P2-GO P2-ATOM P2-INSTANCEOF-PREDICATE P2-BIT-VECTOR-P P2-CHARACTERP P2-CONSP P2-FIXNUMP P2-PACKAGEP P2-READTABLEP P2-SIMPLE-VECTOR-P P2-STRINGP P2-SYMBOLP P2-VECTORP P2-COERCE-TO-FUNCTION P2-BLOCK-NODE P2-RETURN-FROM EMIT-CAR/CDR P2-CAR P2-CDR P2-CONS COMPILE-PROGN P2-EVAL-WHEN P2-LOAD-TIME-VALUE P2-PROGV-NODE P2-QUOTE P2-RPLACD P2-SET-CAR/CDR COMPILE-DECLARE COMPILE-LOCAL-FUNCTION P2-FLET-NODE P2-LABELS-NODE P2-LAMBDA P2-FUNCTION P2-ASH P2-LOGAND P2-LOGIOR P2-LOGXOR P2-LOGNOT P2-%LDB P2-MOD P2-ZEROP P2-FIND-CLASS P2-VECTOR-PUSH-EXTEND P2-STD-SLOT-VALUE P2-SET-STD-SLOT-VALUE P2-STREAM-ELEMENT-TYPE P2-WRITE-8-BITS P2-READ-LINE DERIVE-TYPE-AREF DERIVE-TYPE-FIXNUMP DERIVE-TYPE-SETQ DERIVE-TYPE-LOGIOR/LOGXOR DERIVE-TYPE-LOGAND DERIVE-TYPE-LOGNOT DERIVE-TYPE-MOD DERIVE-TYPE-COERCE DERIVE-TYPE-COPY-SEQ DERIVE-TYPE-INTEGER-LENGTH DERIVE-TYPE-%LDB DERIVE-INTEGER-TYPE DERIVE-TYPE-NUMERIC-OP DERIVE-COMPILER-TYPES DERIVE-TYPE-MINUS DERIVE-TYPE-PLUS DERIVE-TYPE-TIMES DERIVE-TYPE-MAX DERIVE-TYPE-MIN DERIVE-TYPE-READ-CHAR DERIVE-TYPE-ASH DERIVE-TYPE DERIVE-COMPILER-TYPE P2-DELETE P2-LENGTH CONS-FOR-LIST/LIST* P2-LIST P2-LIST* COMPILE-NTH P2-TIMES P2-MIN/MAX P2-PLUS P2-MINUS P2-CHAR/SCHAR P2-SET-CHAR/SCHAR P2-SVREF P2-SVSET P2-TRUNCATE P2-ELT P2-AREF P2-ASET P2-STRUCTURE-REF P2-STRUCTURE-SET P2-NOT/NULL P2-NTHCDR P2-AND P2-OR P2-VALUES COMPILE-SPECIAL-REFERENCE COMPILE-VAR-REF P2-SET P2-SETQ P2-SXHASH P2-SYMBOL-NAME P2-SYMBOL-PACKAGE P2-SYMBOL-VALUE GENERATE-INSTANCEOF-TYPE-CHECK-FOR-VALUE GENERATE-TYPE-CHECK-FOR-VALUE P2-THE P2-TRULY-THE P2-CHAR-CODE P2-JAVA-JCLASS P2-JAVA-JCONSTRUCTOR P2-JAVA-JMETHOD P2-CHAR= P2-THREADS-SYNCHRONIZED-ON P2-CATCH-NODE P2-THROW P2-UNWIND-PROTECT-NODE COMPILE-FORM P2-COMPILAND-PROCESS-TYPE-DECLARATIONS P2-COMPILAND-UNBOX-VARIABLE ASSIGN-FIELD-NAME P2-COMPILAND COMPILE-TO-JVM-CLASS P2-WITH-INLINE-CODE COMPILE-1 MAKE-COMPILER-ERROR-FORM COMPILE-DEFUN NOTE-ERROR-CONTEXT HANDLE-WARNING HANDLE-COMPILER-ERROR %WITH-COMPILATION-UNIT %JVM-COMPILE JVM-COMPILE INITIALIZE-P2-HANDLERS) (("dump-class") READ-U1 READ-U2 READ-U4 LOOKUP-UTF8 READ-CONSTANT-POOL-ENTRY DUMP-CODE DUMP-CODE-ATTRIBUTE DUMP-EXCEPTIONS READ-ATTRIBUTE READ-INFO DUMP-CLASS) (("jvm-class-file") MAP-PRIMITIVE-TYPE PRETTY-CLASS PRETTY-TYPE %MAKE-JVM-CLASS-NAME JVM-CLASS-NAME-P MAKE-JVM-CLASS-NAME CLASS-ARRAY INTERNAL-FIELD-TYPE INTERNAL-FIELD-REF DESCRIPTOR DESCRIPTOR-STACK-EFFECT MAKE-POOL POOL-P MATCHING-INDEX-P FIND-POOL-ENTRY MAKE-CONSTANT CONSTANT-P PRINT-POOL-CONSTANT MAKE-CONSTANT-CLASS CONSTANT-CLASS-P %MAKE-CONSTANT-MEMBER-REF CONSTANT-MEMBER-REF-P MAKE-CONSTANT-FIELD-REF MAKE-CONSTANT-METHOD-REF MAKE-CONSTANT-INTERFACE-METHOD-REF MAKE-CONSTANT-STRING CONSTANT-STRING-P %MAKE-CONSTANT-FLOAT/INT CONSTANT-FLOAT/INT-P MAKE-CONSTANT-FLOAT MAKE-CONSTANT-INT %MAKE-CONSTANT-DOUBLE/LONG CONSTANT-DOUBLE/LONG-P MAKE-CONSTANT-DOUBLE MAKE-CONSTANT-LONG MAKE-CONSTANT-NAME/TYPE CONSTANT-NAME/TYPE-P PARSE-DESCRIPTOR MAKE-CONSTANT-UTF8 CONSTANT-UTF8-P POOL-ADD-CLASS POOL-ADD-FIELD-REF POOL-ADD-METHOD-REF POOL-ADD-INTERFACE-METHOD-REF POOL-ADD-STRING POOL-ADD-INT POOL-ADD-FLOAT POOL-ADD-LONG POOL-ADD-DOUBLE POOL-ADD-NAME/TYPE POOL-ADD-UTF8 MAKE-CLASS-FILE CLASS-FILE-P MAKE-CLASS-INTERFACE-FILE CLASS-ADD-FIELD CLASS-FIELD CLASS-ADD-METHOD CLASS-METHODS-BY-NAME CLASS-METHOD CLASS-REMOVE-METHOD CLASS-ADD-ATTRIBUTE CLASS-ADD-SUPERINTERFACE CLASS-ATTRIBUTE FINALIZE-INTERFACES FINALIZE-CLASS-FILE WRITE-U1 WRITE-U2 WRITE-U4 WRITE-S4 WRITE-ASCII WRITE-UTF8 WRITE-CLASS-FILE WRITE-CONSTANTS PRINT-ENTRY MAP-FLAGS %MAKE-FIELD FIELD-P MAKE-FIELD FIELD-ADD-ATTRIBUTE FIELD-ATTRIBUTE FINALIZE-FIELD WRITE-FIELD %MAKE-JVM-METHOD JVM-METHOD-P MAP-METHOD-NAME MAKE-JVM-METHOD METHOD-ADD-ATTRIBUTE METHOD-ADD-CODE METHOD-ENSURE-CODE METHOD-ATTRIBUTE FINALIZE-METHOD WRITE-METHOD MAKE-ATTRIBUTE ATTRIBUTE-P FINALIZE-ATTRIBUTES WRITE-ATTRIBUTES %MAKE-CODE-ATTRIBUTE CODE-ATTRIBUTE-P CODE-LABEL-OFFSET FINALIZE-CODE-ATTRIBUTE WRITE-CODE-ATTRIBUTE MAKE-CODE-ATTRIBUTE CODE-ADD-ATTRIBUTE CODE-ATTRIBUTE CODE-ADD-EXCEPTION-HANDLER MAKE-EXCEPTION EXCEPTION-P MAKE-CONSTANT-VALUE-ATTRIBUTE CONSTANT-VALUE-ATTRIBUTE-P MAKE-CHECKED-EXCEPTIONS-ATTRIBUTE CHECKED-EXCEPTIONS-ATTRIBUTE-P FINALIZE-CHECKED-EXCEPTIONS WRITE-CHECKED-EXCEPTIONS MAKE-DEPRECATED-ATTRIBUTE DEPRECATED-ATTRIBUTE-P SAVE-CODE-SPECIALS RESTORE-CODE-SPECIALS MAKE-SOURCE-FILE-ATTRIBUTE SOURCE-FILE-ATTRIBUTE-P FINALIZE-SOURCE-FILE WRITE-SOURCE-FILE MAKE-SYNTHETIC-ATTRIBUTE SYNTHETIC-ATTRIBUTE-P MAKE-LINE-NUMBERS-ATTRIBUTE LINE-NUMBERS-ATTRIBUTE-P MAKE-LINE-NUMBER LINE-NUMBER-P FINALIZE-LINE-NUMBERS WRITE-LINE-NUMBERS LINE-NUMBERS-ADD-LINE MAKE-LOCAL-VARIABLES-ATTRIBUTE LOCAL-VARIABLES-ATTRIBUTE-P MAKE-LOCAL-VARIABLE LOCAL-VARIABLE-P FINALIZE-LOCAL-VARIABLES WRITE-LOCAL-VARIABLES MAKE-ANNOTATIONS-ATTRIBUTE ANNOTATIONS-ATTRIBUTE-P MAKE-ANNOTATION ANNOTATION-P MAKE-ANNOTATION-ELEMENT ANNOTATION-ELEMENT-P MAKE-PRIMITIVE-OR-STRING-ANNOTATION-ELEMENT PRIMITIVE-OR-STRING-ANNOTATION-ELEMENT-P MAKE-ENUM-VALUE-ANNOTATION-ELEMENT ENUM-VALUE-ANNOTATION-ELEMENT-P MAKE-ANNOTATION-VALUE-ANNOTATION-ELEMENT ANNOTATION-VALUE-ANNOTATION-ELEMENT-P MAKE-ARRAY-ANNOTATION-ELEMENT ARRAY-ANNOTATION-ELEMENT-P MAKE-RUNTIME-VISIBLE-ANNOTATIONS-ATTRIBUTE RUNTIME-VISIBLE-ANNOTATIONS-ATTRIBUTE-P FINALIZE-ANNOTATIONS FINALIZE-ANNOTATION FINALIZE-ANNOTATION-ELEMENT WRITE-ANNOTATIONS WRITE-ANNOTATION WRITE-ANNOTATION-ELEMENT) (("jvm-instructions") U2 S1 S2 MAKE-JVM-OPCODE JVM-OPCODE-P %DEFINE-OPCODE OPCODE-NAME OPCODE-NUMBER OPCODE-SIZE OPCODE-STACK-EFFECT OPCODE-ARGS-SPEC %MAKE-INSTRUCTION INSTRUCTION-P MAKE-INSTRUCTION PRINT-INSTRUCTION INSTRUCTION-LABEL INST %%EMIT %EMIT LABEL ALOAD ASTORE BRANCH-P UNCONDITIONAL-CONTROL-TRANSFER-P LABEL-P FORMAT-INSTRUCTION-ARGS PRINT-CODE PRINT-CODE2 EXPAND-VIRTUAL-INSTRUCTIONS UNSUPPORTED-OPCODE INITIALIZE-RESOLVERS LOAD/STORE-RESOLVER RESOLVE-INSTRUCTION RESOLVE-INSTRUCTIONS ANALYZE-STACK-PATH ANALYZE-STACK ANALYZE-LOCALS DELETE-UNUSED-LABELS DELETE-UNREACHABLE-CODE LABEL-TARGET-INSTRUCTIONS OPTIMIZE-JUMPS OPTIMIZE-INSTRUCTION-SEQUENCES OPTIMIZE-CODE CODE-BYTES FINALIZE-CODE) (("jvm") INVOKE-CALLBACKS %MAKE-ABCL-CLASS-FILE ABCL-CLASS-FILE-P CLASS-NAME-FROM-FILESPEC MAKE-UNIQUE-CLASS-NAME MAKE-ABCL-CLASS-FILE MAKE-COMPILAND COMPILAND-P COMPILAND-SINGLE-VALUED-P DUMP-1-VARIABLE DUMP-VARIABLES MAKE-VARIABLE VARIABLE-P MAKE-VAR-REF VAR-REF-P UNBOXED-FIXNUM-VARIABLE FIND-VARIABLE FIND-VISIBLE-VARIABLE REPRESENTATION-SIZE ALLOCATE-REGISTER MAKE-LOCAL-FUNCTION LOCAL-FUNCTION-P FIND-LOCAL-FUNCTION MAKE-NODE NODE-P ADD-NODE-CHILD MAKE-CONTROL-TRANSFERRING-NODE CONTROL-TRANSFERRING-NODE-P %MAKE-TAGBODY-NODE TAGBODY-NODE-P MAKE-TAGBODY-NODE %MAKE-CATCH-NODE CATCH-NODE-P MAKE-CATCH-NODE %MAKE-BLOCK-NODE BLOCK-NODE-P MAKE-BLOCK-NODE %MAKE-JUMP-NODE JUMP-NODE-P MAKE-JUMP-NODE MAKE-BINDING-NODE BINDING-NODE-P %MAKE-LET/LET*-NODE LET/LET*-NODE-P MAKE-LET/LET*-NODE %MAKE-FLET-NODE FLET-NODE-P MAKE-FLET-NODE %MAKE-LABELS-NODE LABELS-NODE-P MAKE-LABELS-NODE %MAKE-M-V-B-NODE M-V-B-NODE-P MAKE-M-V-B-NODE %MAKE-PROGV-NODE PROGV-NODE-P MAKE-PROGV-NODE %MAKE-LOCALLY-NODE LOCALLY-NODE-P MAKE-LOCALLY-NODE %MAKE-PROTECTED-NODE PROTECTED-NODE-P MAKE-PROTECTED-NODE %MAKE-UNWIND-PROTECT-NODE UNWIND-PROTECT-NODE-P MAKE-UNWIND-PROTECT-NODE %MAKE-SYNCHRONIZED-NODE SYNCHRONIZED-NODE-P MAKE-SYNCHRONIZED-NODE FIND-BLOCK %FIND-ENCLOSED-BLOCKS FIND-ENCLOSED-BLOCKS SOME-NESTED-BLOCK NODE-CONSTANT-P BLOCK-REQUIRES-NON-LOCAL-EXIT-P NODE-OPSTACK-UNSAFE-P BLOCK-CREATES-RUNTIME-BINDINGS-P ENCLOSED-BY-RUNTIME-BINDINGS-CREATING-BLOCK-P ENCLOSED-BY-PROTECTED-BLOCK-P ENCLOSED-BY-ENVIRONMENT-SETTING-BLOCK-P ENVIRONMENT-REGISTER-TO-RESTORE MAKE-TAG TAG-P FIND-TAG PROCESS-IGNORE/IGNORABLE FINALIZE-GENERIC-FUNCTIONS) (("runtime-class") EMIT-INVOKESPECIAL PARSE-ANNOTATION PARSE-ANNOTATION-ELEMENT)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) ;; MACROS @@ -111,17 +111,17 @@ (DOLIST (SYSTEM::FS (QUOTE ((("compiler-pass1") PUSH-ARGUMENT-BINDING P1-LET/LET*-VARS) (("compiler-pass2") WITH-OPERAND-ACCUMULATION ACCUMULATE-OPERAND DECLARE-WITH-HASHTABLE DEFINE-INLINED-FUNCTION P2-TEST-INTEGER-PREDICATE DEFINE-DERIVE-TYPE-HANDLER DEFINE-INT-BOUNDS-DERIVATION WITH-OPEN-CLASS-FILE WITH-FILE-COMPILATION) (("dump-class") OUT) (("jvm-class-file") DEFINE-CLASS-NAME WITH-CODE-TO-METHOD) (("jvm-instructions") DEFINE-OPCODE EMIT DEFINE-RESOLVER) (("jvm") DFORMAT WITH-SAVED-COMPILER-POLICY WITH-CLASS-FILE)))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) ;; EXPORTS (IN-PACKAGE :EXTENSIONS) -(EXPORT (QUOTE (COLLECT SHOW-RESTARTS *DEBUG-LEVEL* *DEBUG-CONDITION* FEATUREP URL-PATHNAME-FRAGMENT URL-PATHNAME-QUERY URL-PATHNAME-AUTHORITY URL-PATHNAME-SCHEME SOCKET-PEER-ADDRESS SOCKET-LOCAL-ADDRESS SOCKET-LOCAL-PORT SOCKET-PEER-PORT GET-SOCKET-STREAM SOCKET-CLOSE SOCKET-ACCEPT SERVER-SOCKET-CLOSE MAKE-SERVER-SOCKET MAKE-SOCKET))) +(EXPORT (QUOTE (COLLECT COMPILE-SYSTEM SHOW-RESTARTS *DEBUG-LEVEL* *DEBUG-CONDITION* FEATUREP MAKE-DIALOG-PROMPT-STREAM INIT-GUI *GUI-BACKEND* URL-PATHNAME-FRAGMENT URL-PATHNAME-QUERY URL-PATHNAME-AUTHORITY URL-PATHNAME-SCHEME RUN-SHELL-COMMAND SOCKET-PEER-ADDRESS SOCKET-LOCAL-ADDRESS SOCKET-LOCAL-PORT SOCKET-PEER-PORT GET-SOCKET-STREAM SOCKET-CLOSE SOCKET-ACCEPT SERVER-SOCKET-CLOSE MAKE-SERVER-SOCKET MAKE-SOCKET))) ;; FUNCTIONS (IN-PACKAGE :EXTENSIONS) -(DOLIST (SYSTEM::FS (QUOTE ((("collect") COLLECT-NORMAL-EXPANDER COLLECT-LIST-EXPANDER) (("compile-file") COMPILE-FILE-IF-NEEDED) (("compile-system") GROVEL-JAVA-DEFINITIONS COMPILE-SYSTEM) (("debug") SHOW-RESTARTS) (("describe-compiler-policy") DESCRIBE-COMPILER-POLICY) (("featurep") FEATUREP) (("gui") INIT-GUI MAKE-DIALOG-PROMPT-STREAM %MAKE-DIALOG-PROMPT-STREAM) (("pathnames") URL-PATHNAME-SCHEME SET-URL-PATHNAME-SCHEME URL-PATHNAME-AUTHORITY SET-URL-PATHNAME-AUTHORITY URL-PATHNAME-QUERY SET-URL-PATHNAME-QUERY URL-PATHNAME-FRAGMENT SET-URL-PATHNAME-FRAGMENT) (("pprint") CHARPOS) (("run-program") RUN-PROGRAM PROCESS-P PROCESS-ALIVE-P PROCESS-WAIT PROCESS-EXIT-CODE PROCESS-KILL) (("run-shell-command") RUN-SHELL-COMMAND) (("search") SIMPLE-SEARCH) (("socket") GET-SOCKET-STREAM MAKE-SOCKET MAKE-SERVER-SOCKET SOCKET-ACCEPT SOCKET-CLOSE SERVER-SOCKET-CLOSE %SOCKET-ADDRESS %SOCKET-PORT SOCKET-LOCAL-ADDRESS SOCKET-PEER-ADDRESS SOCKET-LOCAL-PORT SOCKET-PEER-PORT)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(DOLIST (SYSTEM::FS (QUOTE ((("collect") COLLECT-NORMAL-EXPANDER COLLECT-LIST-EXPANDER) (("compile-system") COMPILE-SYSTEM) (("debug") SHOW-RESTARTS) (("featurep") FEATUREP) (("gui") INIT-GUI MAKE-DIALOG-PROMPT-STREAM %MAKE-DIALOG-PROMPT-STREAM) (("pathnames") URL-PATHNAME-SCHEME SET-URL-PATHNAME-SCHEME URL-PATHNAME-AUTHORITY SET-URL-PATHNAME-AUTHORITY URL-PATHNAME-QUERY SET-URL-PATHNAME-QUERY URL-PATHNAME-FRAGMENT SET-URL-PATHNAME-FRAGMENT) (("pprint") CHARPOS) (("run-shell-command") RUN-SHELL-COMMAND) (("socket") GET-SOCKET-STREAM MAKE-SOCKET MAKE-SERVER-SOCKET SOCKET-ACCEPT SOCKET-CLOSE SERVER-SOCKET-CLOSE %SOCKET-ADDRESS %SOCKET-PORT SOCKET-LOCAL-ADDRESS SOCKET-PEER-ADDRESS SOCKET-LOCAL-PORT SOCKET-PEER-PORT)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) ;; MACROS (IN-PACKAGE :EXTENSIONS) -(DOLIST (SYSTEM::FS (QUOTE ((("aver") AVER) (("collect") COLLECT)))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(DOLIST (SYSTEM::FS (QUOTE ((("collect") COLLECT)))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) ;; EXPORTS (IN-PACKAGE :THREADS) (EXPORT (QUOTE (RELEASE-MUTEX GET-MUTEX MAKE-MUTEX MAILBOX-PEEK MAILBOX-READ MAILBOX-EMPTY-P MAILBOX-SEND MAKE-MAILBOX WITH-MUTEX WITH-THREAD-LOCK MAKE-THREAD-LOCK))) @@ -145,17 +145,17 @@ ;; EXPORTS (IN-PACKAGE :SYSTEM) -(EXPORT (QUOTE (*COMPILER-DIAGNOSTIC* COMPILER-UNSUPPORTED INTERNAL-COMPILER-ERROR COMPILER-ERROR COMPILER-WARN COMPILER-STYLE-WARN *COMPILER-ERROR-CONTEXT* COMPILER-MACROEXPAND DEFKNOWN FUNCTION-RESULT-TYPE COMPILER-SUBTYPEP MAKE-COMPILER-TYPE JAVA-LONG-TYPE-P INTEGER-CONSTANT-VALUE FIXNUM-CONSTANT-VALUE FIXNUM-TYPE-P +INTEGER-TYPE+ +FIXNUM-TYPE+ MAKE-INTEGER-TYPE %MAKE-INTEGER-TYPE INTEGER-TYPE-P INTEGER-TYPE-HIGH INTEGER-TYPE-LOW +FALSE-TYPE+ +TRUE-TYPE+ COMPILER-DEFSTRUCT PARSE-BODY DUMP-UNINTERNED-SYMBOL-INDEX DUMP-FORM LOOKUP-KNOWN-SYMBOL STANDARD-INSTANCE-ACCESS SLOT-DEFINITION FORWARD-REFERENCED-CLASS LOGICAL-HOST-P *INLINE-DECLARATIONS* FTYPE-RESULT-TYPE PROCLAIMED-FTYPE PROCLAIMED-TYPE CHECK-DECLARATION-TYPE EXPAND-SOURCE-TRANSFORM DEFINE-SOURCE-TRANSFORM SOURCE-TRANSFORM UNTRACED-FUNCTION))) +(EXPORT (QUOTE (AVER *COMPILER-DIAGNOSTIC* COMPILE-FILE-IF-NEEDED GROVEL-JAVA-DEFINITIONS-IN-FILE COMPILER-UNSUPPORTED INTERNAL-COMPILER-ERROR COMPILER-ERROR COMPILER-WARN COMPILER-STYLE-WARN *COMPILER-ERROR-CONTEXT* COMPILER-MACROEXPAND DEFKNOWN FUNCTION-RESULT-TYPE COMPILER-SUBTYPEP MAKE-COMPILER-TYPE JAVA-LONG-TYPE-P INTEGER-CONSTANT-VALUE FIXNUM-CONSTANT-VALUE FIXNUM-TYPE-P +INTEGER-TYPE+ +FIXNUM-TYPE+ MAKE-INTEGER-TYPE %MAKE-INTEGER-TYPE INTEGER-TYPE-P INTEGER-TYPE-HIGH INTEGER-TYPE-LOW +FALSE-TYPE+ +TRUE-TYPE+ COMPILER-DEFSTRUCT DESCRIBE-COMPILER-POLICY PARSE-BODY DUMP-UNINTERNED-SYMBOL-INDEX DUMP-FORM LOOKUP-KNOWN-SYMBOL STANDARD-INSTANCE-ACCESS SLOT-DEFINITION FORWARD-REFERENCED-CLASS LOGICAL-HOST-P *INLINE-DECLARATIONS* FTYPE-RESULT-TYPE PROCLAIMED-FTYPE PROCLAIMED-TYPE CHECK-DECLARATION-TYPE PROCESS-KILL PROCESS-EXIT-CODE PROCESS-WAIT PROCESS-ALIVE-P PROCESS-ERROR PROCESS-OUTPUT PROCESS-INPUT PROCESS-P PROCESS RUN-PROGRAM SIMPLE-SEARCH EXPAND-SOURCE-TRANSFORM DEFINE-SOURCE-TRANSFORM SOURCE-TRANSFORM UNTRACED-FUNCTION))) ;; FUNCTIONS (IN-PACKAGE :SYSTEM) -(DOLIST (FS (QUOTE ((("abcl-contrib") FIND-SYSTEM-JAR FIND-CONTRIB) (("assert") ASSERT-ERROR ASSERT-PROMPT) (("aver") %FAILED-AVER) (("backquote") BACKQUOTE-MACRO COMMA-MACRO EXPANDABLE-BACKQ-EXPRESSION-P BACKQUOTIFY COMMA BACKQUOTIFY-1 BACKQ-LIST BACKQ-LIST* BACKQ-APPEND BACKQ-NCONC BACKQ-CONS BACKQ-VECTOR %READER-ERROR) (("bit-array-ops") BIT-ARRAY-SAME-DIMENSIONS-P REQUIRE-SAME-DIMENSIONS PICK-RESULT-ARRAY) (("case") LIST-OF-LENGTH-AT-LEAST-P CASE-BODY-ERROR CASE-BODY-AUX CASE-BODY) (("check-type") CHECK-TYPE-ERROR) (("clos") COERCE-TO-CONDITION) (("coerce") COERCE-LIST-TO-VECTOR COPY-STRING COERCE-ERROR COERCE-OBJECT-TO-AND-TYPE) (("compile-file-pathname") CFP-OUTPUT-FILE-DEFAULT) (("compile-file") BASE-CLASSNAME FASL-LOADER-CLASSNAME COMPUTE-CLASSFILE-NAME SANITIZE-CLASS-NAME NEXT-CLASSFILE-NAME DUMMY VERIFY-LOAD NOTE-TOPLEVEL-FORM OUTPUT-FORM FINALIZE-FASL-OUTPUT SIMPLE-TOPLEVEL-FORM-P CONVERT-TOPLEVEL-FORM PROCESS-PROGN PRECOMPILE-TOPLEVEL-FORM PROCESS-TOPLEVEL-MACROLET PROCESS-TOPLEVEL-DEFCONSTANT PROCESS-TOPLEVEL-QUOTE PROCESS-TOPLEVEL-IMPORT PROCESS-TOPLEVEL-EXPORT PROCESS-TOPLEVEL-MOP.ENSURE-METHOD PROCESS-TOPLEVEL-DEFVAR/DEFPARAMETER PROCESS-TOPLEVEL-DEFPACKAGE/IN-PACKAGE PROCESS-TOPLEVEL-DECLARE PROCESS-TOPLEVEL-PROGN PROCESS-TOPLEVEL-DEFTYPE PROCESS-TOPLEVEL-EVAL-WHEN PROCESS-TOPLEVEL-DEFMETHOD/DEFGENERIC PROCESS-TOPLEVEL-LOCALLY PROCESS-TOPLEVEL-DEFMACRO PROCESS-TOPLEVEL-DEFUN INSTALL-TOPLEVEL-HANDLER PROCESS-TOPLEVEL-FORM POPULATE-ZIP-FASL WRITE-FASL-PROLOGUE COMPILE-FROM-STREAM) (("compile-system") CHECK-LISP-HOME GROVEL-JAVA-DEFINITIONS-IN-FILE PACKAGES-FROM-COMBOS REMOVE-MULTI-COMBO-SYMBOLS SET-EQUAL COMBOS-TO-SYMBOL-FILESETS COMBOS-TO-FILESET-SYMBOLS WRITE-AUTOLOADER WRITE-PACKAGE-FILESETS LOAD-COMBOS GENERATE-AUTOLOADS %COMPILE-SYSTEM CREATE-SYSTEM-LOGICAL-TRANSLATIONS) (("compiler-error") COMPILER-STYLE-WARN COMPILER-WARN COMPILER-ERROR INTERNAL-COMPILER-ERROR COMPILER-UNSUPPORTED) (("compiler-macro") COMPILER-MACROEXPAND-1 COMPILER-MACROEXPAND) (("compiler-pass2") AUTOCOMPILE) (("compiler-types") MAKE-CONSTANT-TYPE CONSTANT-TYPE-P %MAKE-INTEGER-TYPE INTEGER-TYPE-P MAKE-INTEGER-TYPE FIXNUM-TYPE-P FIXNUM-CONSTANT-VALUE INTEGER-CONSTANT-VALUE JAVA-LONG-TYPE-P MAKE-UNION-TYPE MAKE-COMPILER-TYPE INTEGER-TYPE-SUBTYPEP COMPILER-SUBTYPEP FUNCTION-RESULT-TYPE SET-FUNCTION-RESULT-TYPE %DEFKNOWN) (("concatenate") CONCATENATE-TO-STRING) (("debug") INTERNAL-DEBUG DEBUG-LOOP INVOKE-DEBUGGER-REPORT-CONDITION RUN-HOOK BACKTRACE-AS-LIST) (("define-symbol-macro") %DEFINE-SYMBOL-MACRO) (("defpackage") DESIGNATED-PACKAGE-NAME STRINGIFY-NAMES CHECK-DISJOINT) (("defsetf") %DEFSETF) (("defstruct") MAKE-DEFSTRUCT-DESCRIPTION MAKE-DEFSTRUCT-SLOT-DESCRIPTION KEYWORDIFY DEFINE-KEYWORD-CONSTRUCTOR FIND-DSD GET-SLOT DEFINE-BOA-CONSTRUCTOR DEFAULT-CONSTRUCTOR-NAME DEFINE-CONSTRUCTORS NAME-INDEX DEFINE-PREDICATE MAKE-LIST-READER MAKE-VECTOR-READER MAKE-STRUCTURE-READER DEFINE-READER MAKE-LIST-WRITER MAKE-VECTOR-WRITER MAKE-STRUCTURE-WRITER DEFINE-WRITER DEFINE-ACCESS-FUNCTIONS DEFINE-COPIER DEFINE-PRINT-FUNCTION PARSE-1-OPTION PARSE-NAME-AND-OPTIONS COMPILER-DEFSTRUCT DEFSTRUCT-DEFAULT-CONSTRUCTOR) (("deftype") EXPAND-DEFTYPE) (("delete-duplicates") LIST-DELETE-DUPLICATES* VECTOR-DELETE-DUPLICATES*) (("describe") DESCRIBE-ARGLIST %DESCRIBE-OBJECT) (("destructuring-bind") PARSE-BODY ARG-COUNT-ERROR PARSE-DEFMACRO DEFMACRO-ERROR VERIFY-KEYWORDS LOOKUP-KEYWORD KEYWORD-SUPPLIED-P PARSE-DEFMACRO-LAMBDA-LIST PUSH-SUB-LIST-BINDING PUSH-LET-BINDING PUSH-OPTIONAL-BINDING MAKE-EXPANDER-FOR-MACROLET) (("directory") PATHNAME-AS-FILE WILD-INFERIORS-P LIST-DIRECTORIES-WITH-WILDCARDS) (("do") DO-DO-BODY) (("dump-form") GET-INSTANCE-FORM DF-REGISTER-CIRCULARITY DF-CHECK-CONS DF-CHECK-VECTOR DF-CHECK-INSTANCE DF-CHECK-OBJECT DF-HANDLE-CIRCULARITY DUMP-CONS DUMP-VECTOR DUMP-INSTANCE DUMP-UNINTERNED-SYMBOL-INDEX DUMP-OBJECT DUMP-FORM) (("ed") DEFAULT-ED-FUNCTION) (("enough-namestring") EQUAL-COMPONENTS-P) (("fill") LIST-FILL VECTOR-FILL) (("find") LIST-POSITION* VECTOR-POSITION* LIST-FIND* VECTOR-FIND*) (("format") SYMBOLICATE PROPER-LIST-OF-LENGTH-P FLONUM-TO-STRING ROUND-UP SCALE-EXPONENT FLOAT-DENORMALIZED-P) (("inline") INLINE-EXPANSION SET-INLINE-EXPANSION) (("inspect") LEADER SAFE-LENGTH DISPLAY-OBJECT DISPLAY-CURRENT ISTEP) (("late-setf") MAKE-GENSYM-LIST) (("lcm") TWO-ARG-LCM) (("ldb") %LDB) (("load") LOAD-RETURNING-LAST-RESULT) (("make-sequence") SIZE-MISMATCH-ERROR) (("map1") MAP1) (("nsubstitute") NLIST-SUBSTITUTE* NVECTOR-SUBSTITUTE* NLIST-SUBSTITUTE-IF* NVECTOR-SUBSTITUTE-IF* NLIST-SUBSTITUTE-IF-NOT* NVECTOR-SUBSTITUTE-IF-NOT*) (("open") UPGRADED-ELEMENT-TYPE-BITS UPGRADED-ELEMENT-TYPE) (("parse-integer") PARSE-INTEGER-ERROR) (("parse-lambda-list") PARSE-LAMBDA-LIST-LIKE-THING PARSE-LAMBDA-LIST) (("pathnames") COMPONENT-MATCH-WILD-P COMPONENT-MATCH-P DIRECTORY-MATCH-COMPONENTS DIRECTORY-MATCH-P WILD-P CASIFY TRANSLATE-COMPONENT TRANSLATE-JAR-DEVICE TRANSLATE-DIRECTORY-COMPONENTS-AUX TRANSLATE-DIRECTORY-COMPONENTS TRANSLATE-DIRECTORY LOGICAL-HOST-P CANONICALIZE-LOGICAL-PATHNAME-TRANSLATIONS %SET-LOGICAL-PATHNAME-TRANSLATIONS) (("print-unreadable-object") %PRINT-UNREADABLE-OBJECT) (("print") COMPOUND-OBJECT-P OUTPUT-INTEGER OUTPUT-LIST OUTPUT-TERSE-ARRAY ARRAY-READABLY-PRINTABLE-P OUTPUT-VECTOR OUTPUT-UGLY-OBJECT CHECK-FOR-CIRCULARITY HANDLE-CIRCULARITY PRINT-LABEL PRINT-REFERENCE UNIQUELY-IDENTIFIED-BY-PRINT-P %PRINT-OBJECT %CHECK-OBJECT OUTPUT-OBJECT) (("proclaim") DECLARATION-ERROR CHECK-DECLARATION-TYPE PROCLAIM-TYPE PROCLAIMED-TYPE PROCLAIM-FTYPE-1 PROCLAIM-FTYPE PROCLAIMED-FTYPE FTYPE-RESULT-TYPE) (("query") QUERY-READLINE) (("read-circle") CIRCLE-SUBST SHARP-EQUAL SHARP-SHARP) (("read-conditional") READ-FEATURE READ-CONDITIONAL) (("remove-duplicates") LIST-REMOVE-DUPLICATES VECTOR-REMOVE-DUPLICATES) (("replace") LIST-REPLACE-FROM-LIST* LIST-REPLACE-FROM-VECTOR* VECTOR-REPLACE-FROM-LIST* VECTOR-REPLACE-FROM-VECTOR*) (("run-program") %MAKE-PROCESS MAKE-PROCESS %MAKE-PROCESS-BUILDER %PROCESS-BUILDER-ENVIRONMENT %PROCESS-BUILDER-ENV-PUT %PROCESS-BUILDER-ENV-CLEAR %PROCESS-BUILDER-START %MAKE-PROCESS-INPUT-STREAM %MAKE-PROCESS-OUTPUT-STREAM %MAKE-PROCESS-ERROR-STREAM %PROCESS-ALIVE-P %PROCESS-WAIT %PROCESS-EXIT-CODE %PROCESS-KILL) (("sequences") MAKE-SEQUENCE-OF-TYPE) (("setf") GET-SETF-METHOD-INVERSE EXPAND-OR-GET-SETF-INVERSE %SET-SUBSEQ %DEFINE-SETF-MACRO %SET-CAAR %SET-CADR %SET-CDAR %SET-CDDR %SET-CAAAR %SET-CADAR %SET-CDAAR %SET-CDDAR %SET-CAADR %SET-CADDR %SET-CDADR %SET-CDDDR %SET-CAAAAR %SET-CADAAR %SET-CDAAAR %SET-CDDAAR %SET-CAADAR %SET-CADDAR %SET-CDADAR %SET-CDDDAR %SET-CAAADR %SET-CADADR %SET-CDAADR %SET-CDDADR %SET-CAADDR %SET-CADDDR %SET-CDADDR %SET-CDDDDR %SET-FIFTH %SET-SIXTH %SET-SEVENTH %SET-EIGHTH %SET-NINTH %SET-TENTH) (("sort") MERGE-SORT-VECTORS LAST-CONS-OF MERGE-LISTS MERGE-LISTS-NO-KEY SORT-LIST QUICKSORT QUICK-SORT) (("source-transform") SOURCE-TRANSFORM SET-SOURCE-TRANSFORM EXPAND-SOURCE-TRANSFORM-1 EXPAND-SOURCE-TRANSFORM) (("subst") %SUBST %SUBST-IF %SUBST-IF-NOT) (("subtypep") INITIALIZE-KNOWN-TYPES KNOWN-TYPE-P SUB-INTERVAL-P DIMENSION-SUBTYPEP SIMPLE-SUBTYPEP MAKE-CTYPE CTYPE-SUPER CTYPE-TYPE CTYPE CSUBTYPEP-ARRAY CSUBTYPEP-FUNCTION CSUBTYPEP-COMPLEX CSUBTYPEP %SUBTYPEP) (("time") PICK-OBVIOUS-YEAR LEAP-YEARS-BEFORE) (("trace") MAKE-TRACE-INFO TRACE-INFO-P LIST-TRACED-FUNCTIONS EXPAND-TRACE TRACE-1 TRACED-FUNCTION UNTRACED-FUNCTION TRACE-REDEFINED-UPDATE INDENT UNTRACE-ALL UNTRACE-1) (("tree-equal") TREE-EQUAL-TEST-NOT TREE-EQUAL-TEST) (("typep") SIMPLE-ARRAY-P IN-INTERVAL-P MATCH-DIMENSIONS %TYPEP) (("with-hash-table-iterator") HASH-TABLE-ITERATOR-FUNCTION) (("with-package-iterator") PACKAGE-ITERATOR-FUNCTION) (("with-standard-io-syntax") %WITH-STANDARD-IO-SYNTAX)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR FS) (CAR (CAR FS)))) +(DOLIST (FS (QUOTE ((("abcl-contrib") FIND-SYSTEM-JAR FIND-CONTRIB) (("assert") ASSERT-ERROR ASSERT-PROMPT) (("aver") %FAILED-AVER) (("backquote") BACKQUOTE-MACRO COMMA-MACRO EXPANDABLE-BACKQ-EXPRESSION-P BACKQUOTIFY COMMA BACKQUOTIFY-1 BACKQ-LIST BACKQ-LIST* BACKQ-APPEND BACKQ-NCONC BACKQ-CONS BACKQ-VECTOR %READER-ERROR) (("bit-array-ops") BIT-ARRAY-SAME-DIMENSIONS-P REQUIRE-SAME-DIMENSIONS PICK-RESULT-ARRAY) (("case") LIST-OF-LENGTH-AT-LEAST-P CASE-BODY-ERROR CASE-BODY-AUX CASE-BODY) (("check-type") CHECK-TYPE-ERROR) (("clos") COERCE-TO-CONDITION) (("coerce") COERCE-LIST-TO-VECTOR COPY-STRING COERCE-ERROR COERCE-OBJECT-TO-AND-TYPE) (("compile-file-pathname") CFP-OUTPUT-FILE-DEFAULT) (("compile-file") BASE-CLASSNAME FASL-LOADER-CLASSNAME COMPUTE-CLASSFILE-NAME SANITIZE-CLASS-NAME NEXT-CLASSFILE-NAME DUMMY VERIFY-LOAD NOTE-TOPLEVEL-FORM OUTPUT-FORM FINALIZE-FASL-OUTPUT SIMPLE-TOPLEVEL-FORM-P CONVERT-TOPLEVEL-FORM PROCESS-PROGN PRECOMPILE-TOPLEVEL-FORM PROCESS-TOPLEVEL-MACROLET PROCESS-TOPLEVEL-DEFCONSTANT PROCESS-TOPLEVEL-QUOTE PROCESS-TOPLEVEL-IMPORT PROCESS-TOPLEVEL-EXPORT PROCESS-TOPLEVEL-MOP.ENSURE-METHOD PROCESS-TOPLEVEL-DEFVAR/DEFPARAMETER PROCESS-TOPLEVEL-DEFPACKAGE/IN-PACKAGE PROCESS-TOPLEVEL-DECLARE PROCESS-TOPLEVEL-PROGN PROCESS-TOPLEVEL-DEFTYPE PROCESS-TOPLEVEL-EVAL-WHEN PROCESS-TOPLEVEL-DEFMETHOD/DEFGENERIC PROCESS-TOPLEVEL-LOCALLY PROCESS-TOPLEVEL-DEFMACRO PROCESS-TOPLEVEL-DEFUN INSTALL-TOPLEVEL-HANDLER PROCESS-TOPLEVEL-FORM POPULATE-ZIP-FASL WRITE-FASL-PROLOGUE COMPILE-FROM-STREAM COMPILE-FILE-IF-NEEDED) (("compile-system") CHECK-LISP-HOME GROVEL-JAVA-DEFINITIONS-IN-FILE GROVEL-JAVA-DEFINITIONS PACKAGES-FROM-COMBOS REMOVE-MULTI-COMBO-SYMBOLS SET-EQUAL COMBOS-TO-SYMBOL-FILESETS COMBOS-TO-FILESET-SYMBOLS WRITE-AUTOLOADER WRITE-PACKAGE-FILESETS LOAD-COMBOS GENERATE-AUTOLOADS %COMPILE-SYSTEM CREATE-SYSTEM-LOGICAL-TRANSLATIONS) (("compiler-error") COMPILER-STYLE-WARN COMPILER-WARN COMPILER-ERROR INTERNAL-COMPILER-ERROR COMPILER-UNSUPPORTED) (("compiler-macro") COMPILER-MACROEXPAND-1 COMPILER-MACROEXPAND) (("compiler-pass2") AUTOCOMPILE) (("compiler-types") MAKE-CONSTANT-TYPE CONSTANT-TYPE-P %MAKE-INTEGER-TYPE INTEGER-TYPE-P MAKE-INTEGER-TYPE FIXNUM-TYPE-P FIXNUM-CONSTANT-VALUE INTEGER-CONSTANT-VALUE JAVA-LONG-TYPE-P MAKE-UNION-TYPE MAKE-COMPILER-TYPE INTEGER-TYPE-SUBTYPEP COMPILER-SUBTYPEP FUNCTION-RESULT-TYPE SET-FUNCTION-RESULT-TYPE %DEFKNOWN) (("concatenate") CONCATENATE-TO-STRING) (("debug") INTERNAL-DEBUG DEBUG-LOOP INVOKE-DEBUGGER-REPORT-CONDITION RUN-HOOK BACKTRACE-AS-LIST) (("define-symbol-macro") %DEFINE-SYMBOL-MACRO) (("defpackage") DESIGNATED-PACKAGE-NAME STRINGIFY-NAMES CHECK-DISJOINT) (("defsetf") %DEFSETF) (("defstruct") MAKE-DEFSTRUCT-DESCRIPTION MAKE-DEFSTRUCT-SLOT-DESCRIPTION KEYWORDIFY DEFINE-KEYWORD-CONSTRUCTOR FIND-DSD GET-SLOT DEFINE-BOA-CONSTRUCTOR DEFAULT-CONSTRUCTOR-NAME DEFINE-CONSTRUCTORS NAME-INDEX DEFINE-PREDICATE MAKE-LIST-READER MAKE-VECTOR-READER MAKE-STRUCTURE-READER DEFINE-READER MAKE-LIST-WRITER MAKE-VECTOR-WRITER MAKE-STRUCTURE-WRITER DEFINE-WRITER DEFINE-ACCESS-FUNCTIONS DEFINE-COPIER DEFINE-PRINT-FUNCTION PARSE-1-OPTION PARSE-NAME-AND-OPTIONS COMPILER-DEFSTRUCT DEFSTRUCT-DEFAULT-CONSTRUCTOR) (("deftype") EXPAND-DEFTYPE) (("delete-duplicates") LIST-DELETE-DUPLICATES* VECTOR-DELETE-DUPLICATES*) (("describe-compiler-policy") DESCRIBE-COMPILER-POLICY) (("describe") DESCRIBE-ARGLIST %DESCRIBE-OBJECT) (("destructuring-bind") PARSE-BODY ARG-COUNT-ERROR PARSE-DEFMACRO DEFMACRO-ERROR VERIFY-KEYWORDS LOOKUP-KEYWORD KEYWORD-SUPPLIED-P PARSE-DEFMACRO-LAMBDA-LIST PUSH-SUB-LIST-BINDING PUSH-LET-BINDING PUSH-OPTIONAL-BINDING MAKE-EXPANDER-FOR-MACROLET) (("directory") PATHNAME-AS-FILE WILD-INFERIORS-P LIST-DIRECTORIES-WITH-WILDCARDS) (("do") DO-DO-BODY) (("dump-form") GET-INSTANCE-FORM DF-REGISTER-CIRCULARITY DF-CHECK-CONS DF-CHECK-VECTOR DF-CHECK-INSTANCE DF-CHECK-OBJECT DF-HANDLE-CIRCULARITY DUMP-CONS DUMP-VECTOR DUMP-INSTANCE DUMP-UNINTERNED-SYMBOL-INDEX DUMP-OBJECT DUMP-FORM) (("ed") DEFAULT-ED-FUNCTION) (("enough-namestring") EQUAL-COMPONENTS-P) (("fill") LIST-FILL VECTOR-FILL) (("find") LIST-POSITION* VECTOR-POSITION* LIST-FIND* VECTOR-FIND*) (("format") SYMBOLICATE PROPER-LIST-OF-LENGTH-P FLONUM-TO-STRING ROUND-UP SCALE-EXPONENT FLOAT-DENORMALIZED-P) (("inline") INLINE-EXPANSION SET-INLINE-EXPANSION) (("inspect") LEADER SAFE-LENGTH DISPLAY-OBJECT DISPLAY-CURRENT ISTEP) (("late-setf") MAKE-GENSYM-LIST) (("lcm") TWO-ARG-LCM) (("ldb") %LDB) (("load") LOAD-RETURNING-LAST-RESULT) (("make-sequence") SIZE-MISMATCH-ERROR) (("map1") MAP1) (("nsubstitute") NLIST-SUBSTITUTE* NVECTOR-SUBSTITUTE* NLIST-SUBSTITUTE-IF* NVECTOR-SUBSTITUTE-IF* NLIST-SUBSTITUTE-IF-NOT* NVECTOR-SUBSTITUTE-IF-NOT*) (("open") UPGRADED-ELEMENT-TYPE-BITS UPGRADED-ELEMENT-TYPE) (("parse-integer") PARSE-INTEGER-ERROR) (("parse-lambda-list") PARSE-LAMBDA-LIST-LIKE-THING PARSE-LAMBDA-LIST) (("pathnames") COMPONENT-MATCH-WILD-P COMPONENT-MATCH-P DIRECTORY-MATCH-COMPONENTS DIRECTORY-MATCH-P WILD-P CASIFY TRANSLATE-COMPONENT TRANSLATE-JAR-DEVICE TRANSLATE-DIRECTORY-COMPONENTS-AUX TRANSLATE-DIRECTORY-COMPONENTS TRANSLATE-DIRECTORY LOGICAL-HOST-P CANONICALIZE-LOGICAL-PATHNAME-TRANSLATIONS %SET-LOGICAL-PATHNAME-TRANSLATIONS) (("print-unreadable-object") %PRINT-UNREADABLE-OBJECT) (("print") COMPOUND-OBJECT-P OUTPUT-INTEGER OUTPUT-LIST OUTPUT-TERSE-ARRAY ARRAY-READABLY-PRINTABLE-P OUTPUT-VECTOR OUTPUT-UGLY-OBJECT CHECK-FOR-CIRCULARITY HANDLE-CIRCULARITY PRINT-LABEL PRINT-REFERENCE UNIQUELY-IDENTIFIED-BY-PRINT-P %PRINT-OBJECT %CHECK-OBJECT OUTPUT-OBJECT) (("proclaim") DECLARATION-ERROR CHECK-DECLARATION-TYPE PROCLAIM-TYPE PROCLAIMED-TYPE PROCLAIM-FTYPE-1 PROCLAIM-FTYPE PROCLAIMED-FTYPE FTYPE-RESULT-TYPE) (("query") QUERY-READLINE) (("read-circle") CIRCLE-SUBST SHARP-EQUAL SHARP-SHARP) (("read-conditional") READ-FEATURE READ-CONDITIONAL) (("remove-duplicates") LIST-REMOVE-DUPLICATES VECTOR-REMOVE-DUPLICATES) (("replace") LIST-REPLACE-FROM-LIST* LIST-REPLACE-FROM-VECTOR* VECTOR-REPLACE-FROM-LIST* VECTOR-REPLACE-FROM-VECTOR*) (("run-program") RUN-PROGRAM %MAKE-PROCESS PROCESS-P MAKE-PROCESS PROCESS-ALIVE-P PROCESS-WAIT PROCESS-EXIT-CODE PROCESS-KILL %MAKE-PROCESS-BUILDER %PROCESS-BUILDER-ENVIRONMENT %PROCESS-BUILDER-ENV-PUT %PROCESS-BUILDER-ENV-CLEAR %PROCESS-BUILDER-START %MAKE-PROCESS-INPUT-STREAM %MAKE-PROCESS-OUTPUT-STREAM %MAKE-PROCESS-ERROR-STREAM %PROCESS-ALIVE-P %PROCESS-WAIT %PROCESS-EXIT-CODE %PROCESS-KILL) (("search") SIMPLE-SEARCH) (("sequences") MAKE-SEQUENCE-OF-TYPE) (("setf") GET-SETF-METHOD-INVERSE EXPAND-OR-GET-SETF-INVERSE %SET-SUBSEQ %DEFINE-SETF-MACRO %SET-CAAR %SET-CADR %SET-CDAR %SET-CDDR %SET-CAAAR %SET-CADAR %SET-CDAAR %SET-CDDAR %SET-CAADR %SET-CADDR %SET-CDADR %SET-CDDDR %SET-CAAAAR %SET-CADAAR %SET-CDAAAR %SET-CDDAAR %SET-CAADAR %SET-CADDAR %SET-CDADAR %SET-CDDDAR %SET-CAAADR %SET-CADADR %SET-CDAADR %SET-CDDADR %SET-CAADDR %SET-CADDDR %SET-CDADDR %SET-CDDDDR %SET-FIFTH %SET-SIXTH %SET-SEVENTH %SET-EIGHTH %SET-NINTH %SET-TENTH) (("sort") MERGE-SORT-VECTORS LAST-CONS-OF MERGE-LISTS MERGE-LISTS-NO-KEY SORT-LIST QUICKSORT QUICK-SORT) (("source-transform") SOURCE-TRANSFORM SET-SOURCE-TRANSFORM EXPAND-SOURCE-TRANSFORM-1 EXPAND-SOURCE-TRANSFORM) (("subst") %SUBST %SUBST-IF %SUBST-IF-NOT) (("subtypep") INITIALIZE-KNOWN-TYPES KNOWN-TYPE-P SUB-INTERVAL-P DIMENSION-SUBTYPEP SIMPLE-SUBTYPEP MAKE-CTYPE CTYPE-SUPER CTYPE-TYPE CTYPE CSUBTYPEP-ARRAY CSUBTYPEP-FUNCTION CSUBTYPEP-COMPLEX CSUBTYPEP %SUBTYPEP) (("time") PICK-OBVIOUS-YEAR LEAP-YEARS-BEFORE) (("trace") MAKE-TRACE-INFO TRACE-INFO-P LIST-TRACED-FUNCTIONS EXPAND-TRACE TRACE-1 TRACED-FUNCTION UNTRACED-FUNCTION TRACE-REDEFINED-UPDATE INDENT UNTRACE-ALL UNTRACE-1) (("tree-equal") TREE-EQUAL-TEST-NOT TREE-EQUAL-TEST) (("typep") SIMPLE-ARRAY-P IN-INTERVAL-P MATCH-DIMENSIONS %TYPEP) (("with-hash-table-iterator") HASH-TABLE-ITERATOR-FUNCTION) (("with-package-iterator") PACKAGE-ITERATOR-FUNCTION) (("with-standard-io-syntax") %WITH-STANDARD-IO-SYNTAX)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR FS) (CAR (CAR FS)))) ;; MACROS (IN-PACKAGE :SYSTEM) -(DOLIST (FS (QUOTE ((("assoc") ASSOC-GUTS) (("chars") EQUAL-CHAR-CODE) (("compile-file") REPORT-ERROR DIAG) (("compiler-types") DEFKNOWN) (("copy-seq") VECTOR-COPY-SEQ LIST-COPY-SEQ) (("define-modify-macro") INCF-COMPLEX DECF-COMPLEX) (("defstruct") DD-NAME DD-CONC-NAME DD-DEFAULT-CONSTRUCTOR DD-CONSTRUCTORS DD-COPIER DD-INCLUDE DD-TYPE DD-NAMED DD-INITIAL-OFFSET DD-PREDICATE DD-PRINT-FUNCTION DD-PRINT-OBJECT DD-DIRECT-SLOTS DD-SLOTS DD-INHERITED-ACCESSORS DSD-NAME DSD-INDEX DSD-READER DSD-INITFORM DSD-TYPE DSD-READ-ONLY) (("delete") MUMBLE-DELETE MUMBLE-DELETE-FROM-END NORMAL-MUMBLE-DELETE NORMAL-MUMBLE-DELETE-FROM-END LIST-DELETE LIST-DELETE-FROM-END NORMAL-LIST-DELETE NORMAL-LIST-DELETE-FROM-END IF-MUMBLE-DELETE IF-MUMBLE-DELETE-FROM-END IF-LIST-DELETE IF-LIST-DELETE-FROM-END IF-NOT-MUMBLE-DELETE IF-NOT-MUMBLE-DELETE-FROM-END IF-NOT-LIST-DELETE IF-NOT-LIST-DELETE-FROM-END) (("find") VECTOR-LOCATER-MACRO LOCATER-TEST-NOT VECTOR-LOCATER LOCATER-IF-TEST VECTOR-LOCATER-IF-MACRO VECTOR-LOCATER-IF VECTOR-LOCATER-IF-NOT LIST-LOCATER-MACRO LIST-LOCATER LIST-LOCATER-IF-MACRO LIST-LOCATER-IF LIST-LOCATER-IF-NOT VECTOR-POSITION LIST-POSITION VECTOR-POSITION-IF LIST-POSITION-IF VECTOR-POSITION-IF-NOT LIST-POSITION-IF-NOT VECTOR-FIND LIST-FIND VECTOR-FIND-IF LIST-FIND-IF VECTOR-FIND-IF-NOT LIST-FIND-IF-NOT) (("format") NAMED-LET ONCE-ONLY) (("list") APPLY-KEY) (("print") PUNT-PRINT-IF-TOO-LONG) (("reduce") LIST-REDUCE LIST-REDUCE-FROM-END) (("remove") MUMBLE-REMOVE-MACRO MUMBLE-REMOVE MUMBLE-REMOVE-FROM-END NORMAL-MUMBLE-REMOVE NORMAL-MUMBLE-REMOVE-FROM-END IF-MUMBLE-REMOVE IF-MUMBLE-REMOVE-FROM-END IF-NOT-MUMBLE-REMOVE IF-NOT-MUMBLE-REMOVE-FROM-END LIST-REMOVE-MACRO LIST-REMOVE LIST-REMOVE-FROM-END NORMAL-LIST-REMOVE NORMAL-LIST-REMOVE-FROM-END IF-LIST-REMOVE IF-LIST-REMOVE-FROM-END IF-NOT-LIST-REMOVE IF-NOT-LIST-REMOVE-FROM-END) (("sequences") TYPE-SPECIFIER-ATOM MAKE-SEQUENCE-LIKE) (("sets") WITH-SET-KEYS STEVE-SPLICE) (("sort") MERGE-VECTORS-BODY MERGE-SORT-BODY QUICKSORT-BODY) (("source-transform") DEFINE-SOURCE-TRANSFORM) (("subst") SATISFIES-THE-TEST)))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR FS) (CAR (CAR FS)))) +(DOLIST (FS (QUOTE ((("assoc") ASSOC-GUTS) (("aver") AVER) (("chars") EQUAL-CHAR-CODE) (("compile-file") REPORT-ERROR DIAG) (("compiler-types") DEFKNOWN) (("copy-seq") VECTOR-COPY-SEQ LIST-COPY-SEQ) (("define-modify-macro") INCF-COMPLEX DECF-COMPLEX) (("defstruct") DD-NAME DD-CONC-NAME DD-DEFAULT-CONSTRUCTOR DD-CONSTRUCTORS DD-COPIER DD-INCLUDE DD-TYPE DD-NAMED DD-INITIAL-OFFSET DD-PREDICATE DD-PRINT-FUNCTION DD-PRINT-OBJECT DD-DIRECT-SLOTS DD-SLOTS DD-INHERITED-ACCESSORS DSD-NAME DSD-INDEX DSD-READER DSD-INITFORM DSD-TYPE DSD-READ-ONLY) (("delete") MUMBLE-DELETE MUMBLE-DELETE-FROM-END NORMAL-MUMBLE-DELETE NORMAL-MUMBLE-DELETE-FROM-END LIST-DELETE LIST-DELETE-FROM-END NORMAL-LIST-DELETE NORMAL-LIST-DELETE-FROM-END IF-MUMBLE-DELETE IF-MUMBLE-DELETE-FROM-END IF-LIST-DELETE IF-LIST-DELETE-FROM-END IF-NOT-MUMBLE-DELETE IF-NOT-MUMBLE-DELETE-FROM-END IF-NOT-LIST-DELETE IF-NOT-LIST-DELETE-FROM-END) (("find") VECTOR-LOCATER-MACRO LOCATER-TEST-NOT VECTOR-LOCATER LOCATER-IF-TEST VECTOR-LOCATER-IF-MACRO VECTOR-LOCATER-IF VECTOR-LOCATER-IF-NOT LIST-LOCATER-MACRO LIST-LOCATER LIST-LOCATER-IF-MACRO LIST-LOCATER-IF LIST-LOCATER-IF-NOT VECTOR-POSITION LIST-POSITION VECTOR-POSITION-IF LIST-POSITION-IF VECTOR-POSITION-IF-NOT LIST-POSITION-IF-NOT VECTOR-FIND LIST-FIND VECTOR-FIND-IF LIST-FIND-IF VECTOR-FIND-IF-NOT LIST-FIND-IF-NOT) (("format") NAMED-LET ONCE-ONLY) (("list") APPLY-KEY) (("print") PUNT-PRINT-IF-TOO-LONG) (("reduce") LIST-REDUCE LIST-REDUCE-FROM-END) (("remove") MUMBLE-REMOVE-MACRO MUMBLE-REMOVE MUMBLE-REMOVE-FROM-END NORMAL-MUMBLE-REMOVE NORMAL-MUMBLE-REMOVE-FROM-END IF-MUMBLE-REMOVE IF-MUMBLE-REMOVE-FROM-END IF-NOT-MUMBLE-REMOVE IF-NOT-MUMBLE-REMOVE-FROM-END LIST-REMOVE-MACRO LIST-REMOVE LIST-REMOVE-FROM-END NORMAL-LIST-REMOVE NORMAL-LIST-REMOVE-FROM-END IF-LIST-REMOVE IF-LIST-REMOVE-FROM-END IF-NOT-LIST-REMOVE IF-NOT-LIST-REMOVE-FROM-END) (("sequences") TYPE-SPECIFIER-ATOM MAKE-SEQUENCE-LIKE) (("sets") WITH-SET-KEYS STEVE-SPLICE) (("sort") MERGE-VECTORS-BODY MERGE-SORT-BODY QUICKSORT-BODY) (("source-transform") DEFINE-SOURCE-TRANSFORM) (("subst") SATISFIES-THE-TEST)))) (FUNCALL (FUNCTION AUTOLOAD-MACRO) (CDR FS) (CAR (CAR FS)))) ;; EXPORTS (IN-PACKAGE :CL) (EXPORT (QUOTE (NBUTLAST BUTLAST IGNORE-ERRORS MAP-INTO MISMATCH METHOD-QUALIFIERS COMPUTE-APPLICABLE-METHODS STANDARD-METHOD SUBSTITUTE-IF-NOT SUBSTITUTE-IF SUBSTITUTE))) From ehuelsmann at common-lisp.net Sat Aug 18 12:34:15 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 18 Aug 2012 05:34:15 -0700 Subject: [armedbear-cvs] r14123 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 18 05:34:14 2012 New Revision: 14123 Log: Move RUN-SHELL-COMMAND to the EXTENSIONS package. Remove superfluous exports from autoloads.lisp. Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp trunk/abcl/src/org/armedbear/lisp/run-shell-command.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Sat Aug 18 05:32:39 2012 (r14122) +++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Sat Aug 18 05:34:14 2012 (r14123) @@ -46,11 +46,6 @@ ;; loaded through loading jvm.lisp. -(in-package "SYSTEM") - -(export '%ldb '#:system) -(export 'concatenate-to-string '#:system) - ;; Extensions. (in-package "EXTENSIONS") Modified: trunk/abcl/src/org/armedbear/lisp/run-shell-command.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/run-shell-command.lisp Sat Aug 18 05:32:39 2012 (r14122) +++ trunk/abcl/src/org/armedbear/lisp/run-shell-command.lisp Sat Aug 18 05:34:14 2012 (r14123) @@ -29,7 +29,7 @@ ;;; obligated to do so. If you do not wish to do so, delete this ;;; exception statement from your version. -(in-package "SYSTEM") +(in-package "EXTENSIONS") (export '(run-shell-command)) From ehuelsmann at common-lisp.net Sat Aug 18 13:47:20 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 18 Aug 2012 06:47:20 -0700 Subject: [armedbear-cvs] r14124 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 18 06:47:12 2012 New Revision: 14124 Log: %RUN-SHELL-COMMAND is in the SYSTEM package. Access it as such. Modified: trunk/abcl/src/org/armedbear/lisp/run-shell-command.lisp Modified: trunk/abcl/src/org/armedbear/lisp/run-shell-command.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/run-shell-command.lisp Sat Aug 18 05:34:14 2012 (r14123) +++ trunk/abcl/src/org/armedbear/lisp/run-shell-command.lisp Sat Aug 18 06:47:12 2012 (r14124) @@ -34,4 +34,4 @@ (export '(run-shell-command)) (defun run-shell-command (command &key directory (output *standard-output*)) - (%run-shell-command command directory output)) + (sys::%run-shell-command command directory output)) From ehuelsmann at common-lisp.net Sat Aug 18 13:49:38 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 18 Aug 2012 06:49:38 -0700 Subject: [armedbear-cvs] r14125 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 18 06:49:37 2012 New Revision: 14125 Log: Break circular dependency when printing errors when FORMAT isn't fully autoloaded. Modified: trunk/abcl/src/org/armedbear/lisp/format.lisp Modified: trunk/abcl/src/org/armedbear/lisp/format.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/format.lisp Sat Aug 18 06:47:12 2012 (r14124) +++ trunk/abcl/src/org/armedbear/lisp/format.lisp Sat Aug 18 06:49:37 2012 (r14125) @@ -33,6 +33,16 @@ (in-package "SYSTEM") +;; If we're here due to an autoloader, +;; we should prevent a circular dependency: +;; when the debugger tries to print an error, +;; it autoloads us, but if that autoloading causes +;; another error, it circularly starts autoloading us. +;; +;; So, we replace whatever is in the function slot until +;; we can reliably call FORMAT +(setf (symbol-function 'format) #'sys::%format) + (require "PRINT-OBJECT") ;;; From primordial-extensions.lisp. From ehuelsmann at common-lisp.net Sat Aug 18 19:21:59 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 18 Aug 2012 12:21:59 -0700 Subject: [armedbear-cvs] r14126 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 18 12:21:57 2012 New Revision: 14126 Log: Closes #226: All exports and all but one autoload have been removed from autoloads.lisp due to automatic loading. Documentation inside autoloads.lisp has also been updated. Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Sat Aug 18 06:49:37 2012 (r14125) +++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Sat Aug 18 12:21:57 2012 (r14126) @@ -30,31 +30,17 @@ ;;; exception statement from your version. -;; This file lists public functions which package users can depend upon. -;; -;; In order to avoid loading the full CL system (of which not all functions -;; may be required by the current program), this file makes sure the symbols -;; are available, but when it tries to execute them, the autoloader causes -;; the actual functions or macros to be loaded. - -;; This file lists for each autoloaded symbol which file has to be -;; REQUIRE'd to make it available. -;; -;; Please note: the actual function definition may not be always in the -;; same file as the one which needs to be REQUIRE'd; an example of -;; such a case is the compiler: all compiler functions have to be -;; loaded through loading jvm.lisp. - +;; ABOUT THIS FILE +;; In order to avoid loading the full CL system (of which not all functions +;; may be required by the current program), this file makes sure symbols +;; of public functions have their function slots bound to a proxy function +;; which loads the actual functions or macros on invocation. + +;; There are two autoloader files: autoload-gen.lisp, which is automatically +;; generated based on the source files, and this file, which is manually +;; maintained for any symbols that can't be automatically detected. -;; Extensions. -(in-package "EXTENSIONS") - -;; due to the macro-expansion of DEFSTRUCT, -;; slot accessors aren't being "detected" -(autoload 'process-input "run-program") -(autoload 'process-output "run-program") -(autoload 'process-error "run-program") From ehuelsmann at common-lisp.net Sun Aug 19 13:20:01 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 19 Aug 2012 06:20:01 -0700 Subject: [armedbear-cvs] r14127 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 19 06:20:00 2012 New Revision: 14127 Log: Reindent documentation string. Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/java.lisp Sat Aug 18 12:21:57 2012 (r14126) +++ trunk/abcl/src/org/armedbear/lisp/java.lisp Sun Aug 19 06:20:00 2012 (r14127) @@ -396,7 +396,16 @@ ;;; higher-level operators (defmacro chain (target op &rest ops) - "Performs chained method invocations. `target' is the receiver object (when the first call is a virtual method call) or a list in the form (:static ) when the first method call is a static method call. `op' and each of the `ops' are either method designators or lists in the form ( &rest args), where a method designator is either a string naming a method, or a jmethod object. `chain' will perform the method call specified by `op' on `target'; then, for each of the `ops', `chain' will perform the specified method call using the object returned by the previous method call as the receiver, and will ultimately return the result of the last method call. + "Performs chained method invocations. `target' is the receiver +object (when the first call is a virtual method call) or a list in the +form (:static ) when the first method call is a static method +call. `op' and each of the `ops' are either method designators or lists +in the form ( &rest args), where a method designator +is either a string naming a method, or a jmethod object. `chain' will +perform the method call specified by `op' on `target'; then, for each +of the `ops', `chain' will perform the specified method call using the +object returned by the previous method call as the receiver, and will +ultimately return the result of the last method call. For example, the form: (chain (:static \"java.lang.Runtime\") \"getRuntime\" (\"exec\" \"ls\")) From ehuelsmann at common-lisp.net Sun Aug 19 13:22:44 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 19 Aug 2012 06:22:44 -0700 Subject: [armedbear-cvs] r14128 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 19 06:22:43 2012 New Revision: 14128 Log: Fix #113 (redefinition of structures can crash ABCL) by failing the redefinition if the two structure definitions are not equalp. Modified: trunk/abcl/src/org/armedbear/lisp/defstruct.lisp Modified: trunk/abcl/src/org/armedbear/lisp/defstruct.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/defstruct.lisp Sun Aug 19 06:20:00 2012 (r14127) +++ trunk/abcl/src/org/armedbear/lisp/defstruct.lisp Sun Aug 19 06:22:43 2012 (r14128) @@ -517,8 +517,8 @@ slots inherited-accessors documentation) - (setf (get name 'structure-definition) - (make-defstruct-description :name name + (let ((description + (make-defstruct-description :name name :conc-name conc-name :default-constructor default-constructor :constructors constructors @@ -533,6 +533,27 @@ :direct-slots direct-slots :slots slots :inherited-accessors inherited-accessors)) + (old (get name 'structure-definition))) + (when old + (unless + ;; Assert that the structure definitions are exactly the same + ;; we need to support this type of redefinition during bootstrap + ;; building ourselves + (and (equalp (aref old 0) (aref description 0)) + ;; the CONC-NAME slot is an uninterned symbol if not supplied + ;; thus different on each redefinition round. Check that the + ;; names are equal, because it produces the same end result + ;; when they are. + (string= (aref old 1) (aref description 1)) + (dotimes (index 13 t) + (when (not (equalp (aref old (+ 2 index)) + (aref description (+ 2 index)))) + (return nil)))) + (error 'program-error + :format-control "Structure redefinition not supported ~ + in DEFSTRUCT for ~A" + :format-arguments (list name)))) + (setf (get name 'structure-definition) description)) (%set-documentation name 'structure documentation) (when (or (null type) named) (let ((structure-class From ehuelsmann at common-lisp.net Sun Aug 19 13:53:29 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 19 Aug 2012 06:53:29 -0700 Subject: [armedbear-cvs] r14129 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 19 06:53:28 2012 New Revision: 14129 Log: Follow up to r14128: if the descriptions are the same, continue with the old one. Modified: trunk/abcl/src/org/armedbear/lisp/defstruct.lisp Modified: trunk/abcl/src/org/armedbear/lisp/defstruct.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/defstruct.lisp Sun Aug 19 06:22:43 2012 (r14128) +++ trunk/abcl/src/org/armedbear/lisp/defstruct.lisp Sun Aug 19 06:53:28 2012 (r14129) @@ -552,7 +552,9 @@ (error 'program-error :format-control "Structure redefinition not supported ~ in DEFSTRUCT for ~A" - :format-arguments (list name)))) + :format-arguments (list name))) + ;; Since they're the same, continue with the old one. + (setf description old)) (setf (get name 'structure-definition) description)) (%set-documentation name 'structure documentation) (when (or (null type) named) From ehuelsmann at common-lisp.net Mon Aug 20 18:39:27 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Mon, 20 Aug 2012 11:39:27 -0700 Subject: [armedbear-cvs] r14130 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Aug 20 11:39:26 2012 New Revision: 14130 Log: Replace a Java primitive LAMBDA-LIST-NAMES with a lisp function. Make the returned REQUIRED value from PARSE-LAMBDA-LIST match is docstring. Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Closure.java Sun Aug 19 06:53:28 2012 (r14129) +++ trunk/abcl/src/org/armedbear/lisp/Closure.java Mon Aug 20 11:39:26 2012 (r14130) @@ -220,16 +220,4 @@ { return arglist.match(args, environment, environment, thread); } - - // ### lambda-list-names - private static final Primitive LAMBDA_LIST_NAMES = - new Primitive("lambda-list-names", PACKAGE_SYS, true) - { - @Override - public LispObject execute(LispObject arg) - { - Closure closure = new Closure(list(Symbol.LAMBDA, arg, NIL), new Environment()); - return closure.getVariableList(); - } - }; } Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun Aug 19 06:53:28 2012 (r14129) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Mon Aug 20 11:39:26 2012 (r14130) @@ -107,7 +107,7 @@ (&environment (setf state :env)) (t (case state - (:req (push arg req)) + (:req (push (list arg) req)) (:rest (setf rest (list arg) state :none)) (:env (setf env (list arg) @@ -176,7 +176,8 @@ (let (req-bindings temp-bindings bindings ignorables) ;;Required arguments. (setf req-bindings - (loop :for var :in req :collect `(,var ,(pop-required-argument)))) + (loop :for (var) :in req + :collect `(,var ,(pop-required-argument)))) ;;Optional arguments. (when opt @@ -758,6 +759,17 @@ (values (nreverse other-decls) (nreverse specific-decls)))) +(defun lambda-list-names (lambda-list) + "Returns a list of variable names extracted from `lambda-list'." + (multiple-value-bind + (req opt key key-p rest allow-key-p aux whole env) + (parse-lambda-list lambda-list) + (declare (ignore key-p allow-key-p)) + (mapcan (lambda (x) + (mapcar #'first x)) + (list req opt key aux rest whole env)))) + + (defun rewrite-aux-vars (form) (let* ((lambda-list (cadr form)) (aux-p (memq '&AUX lambda-list)) From ehuelsmann at common-lisp.net Tue Aug 21 14:00:21 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 21 Aug 2012 07:00:21 -0700 Subject: [armedbear-cvs] r14131 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Aug 21 07:00:13 2012 New Revision: 14131 Log: Close #219: lambda list keyword checking too lenient for ANSI. Note: This introduces a new argument to the FUNCTION special form (LAMBDA and NAMED-LAMBDA were already supported) (FUNCTION (MACRO-FUNCTION ...)) Modified: trunk/abcl/src/org/armedbear/lisp/ArgumentListProcessor.java trunk/abcl/src/org/armedbear/lisp/Closure.java trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java Modified: trunk/abcl/src/org/armedbear/lisp/ArgumentListProcessor.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ArgumentListProcessor.java Mon Aug 20 11:39:26 2012 (r14130) +++ trunk/abcl/src/org/armedbear/lisp/ArgumentListProcessor.java Tue Aug 21 07:00:13 2012 (r14131) @@ -38,9 +38,17 @@ import java.util.ArrayList; import static org.armedbear.lisp.Lisp.*; -/** A class to parse a lambda list and match function call arguments with it +/** A class to parse a lambda list and match function call arguments with it. + * + * The lambda list may either be of type ORDINARY or MACRO lambda list. + * All other lambda lists are parsed elsewhere in our code base. */ public class ArgumentListProcessor { + + public enum LambdaListType { + ORDINARY, + MACRO + } // States. private static final int STATE_REQUIRED = 0; @@ -162,7 +170,8 @@ * @param specials A list of symbols specifying which variables to * bind as specials during initform evaluation */ - public ArgumentListProcessor(Operator fun, LispObject lambdaList, LispObject specials) { + public ArgumentListProcessor(Operator fun, LispObject lambdaList, + LispObject specials, LambdaListType type) { function = fun; boolean _andKey = false; @@ -176,11 +185,28 @@ ArrayList aux = null; int state = STATE_REQUIRED; LispObject remaining = lambdaList; + + if (remaining.car() == Symbol.AND_WHOLE) { + if (type == LambdaListType.ORDINARY) { + error(new ProgramError("&WHOLE not allowed in ordinary lambda lists.")); + } else { + // skip the &WHOLE part of the lambda list + remaining = remaining.cdr().cdr(); + } + } + + while (remaining != NIL) { LispObject obj = remaining.car(); if (obj instanceof Symbol) { + if (obj == Symbol.AND_WHOLE) { + if (type == LambdaListType.ORDINARY) + error(new ProgramError("&WHOLE not allowed in ordinary lambda lists.")); + else + error(new ProgramError("&WHOLE must appear first in macro lambda list.")); + } if (state == STATE_AUX) { if (aux == null) @@ -200,6 +226,8 @@ error(new ProgramError( "&REST/&BODY must precede &KEY.")); } + if (type == LambdaListType.ORDINARY && obj == Symbol.AND_BODY) + error(new ProgramError("&BODY not allowed in ordinary lambda lists.")); state = STATE_REST; arity = -1; maxArgs = -1; @@ -228,6 +256,8 @@ } else if (obj == Symbol.AND_ENVIRONMENT) { + if (type == LambdaListType.ORDINARY) + error(new ProgramError("&ENVIRONMENT not allowed in ordinary lambda lists.")); remaining = remaining.cdr(); envVar = (Symbol) remaining.car(); envParam = new EnvironmentParam(envVar, isSpecial(envVar, specials)); Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Closure.java Mon Aug 20 11:39:26 2012 (r14130) +++ trunk/abcl/src/org/armedbear/lisp/Closure.java Tue Aug 21 07:00:13 2012 (r14131) @@ -95,7 +95,16 @@ this.environment = env; - arglist = new ArgumentListProcessor(this, lambdaList, specials); + /* In the bootstrapping process, functions with MACRO LAMBDA LIST + * lambda list types are being generated using the MACRO_FUNCTION instead + * of the LAMBDA or NAMED_LAMBDA keys. + * + * Use that to perform argument list lambda list keyword checking. + */ + arglist = new ArgumentListProcessor(this, lambdaList, specials, + (lambdaExpression.car() == Symbol.MACRO_FUNCTION) ? + ArgumentListProcessor.LambdaListType.MACRO + : ArgumentListProcessor.LambdaListType.ORDINARY); freeSpecials = arglist.freeSpecials(specials); } Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java Mon Aug 20 11:39:26 2012 (r14130) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Tue Aug 21 07:00:13 2012 (r14131) @@ -1879,12 +1879,18 @@ public LispObject execute(LispObject args, Environment env) { + /* Create an expansion function + * `(lambda (,formArg ,envArg) + * (apply (function (macro-function ,lambdaList + * (block ,symbol , at body))) + * (cdr ,formArg))) + */ Symbol symbol = checkSymbol(args.car()); LispObject lambdaList = checkList(args.cadr()); LispObject body = args.cddr(); LispObject block = new Cons(Symbol.BLOCK, new Cons(symbol, body)); LispObject toBeApplied = - list(Symbol.FUNCTION, list(Symbol.LAMBDA, lambdaList, block)); + list(Symbol.FUNCTION, list(Symbol.MACRO_FUNCTION, lambdaList, block)); final LispThread thread = LispThread.currentThread(); LispObject formArg = gensym("FORM-", thread); LispObject envArg = gensym("ENV-", thread); // Ignored. @@ -1899,8 +1905,8 @@ put(symbol, Symbol.MACROEXPAND_MACRO, macroObject); else symbol.setSymbolFunction(macroObject); - macroObject.setLambdaList(lambdaList); - thread._values = null; + macroObject.setLambdaList(args.cadr()); + LispThread.currentThread()._values = null; return symbol; } }; @@ -3656,13 +3662,19 @@ public LispObject execute(LispObject definition) { + /* Create an expansion function + * `(lambda (,formArg ,envArg) + * (apply (function (macro-function ,lambdaList + * (block ,symbol , at body))) + * (cdr ,formArg))) + */ Symbol symbol = checkSymbol(definition.car()); LispObject lambdaList = definition.cadr(); LispObject body = definition.cddr(); LispObject block = new Cons(Symbol.BLOCK, new Cons(symbol, body)); LispObject toBeApplied = - list(Symbol.LAMBDA, lambdaList, block); + list(Symbol.FUNCTION, list(Symbol.MACRO_FUNCTION, lambdaList, block)); final LispThread thread = LispThread.currentThread(); LispObject formArg = gensym("WHOLE-", thread); LispObject envArg = gensym("ENVIRONMENT-", thread); // Ignored. Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java Mon Aug 20 11:39:26 2012 (r14130) +++ trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java Tue Aug 21 07:00:13 2012 (r14131) @@ -498,6 +498,8 @@ } return type_error(name, FUNCTION_NAME); } + if (car == Symbol.MACRO_FUNCTION) + return new Closure(arg, env); } return error(new UndefinedFunction(list(Keyword.NAME, arg))); } From ehuelsmann at common-lisp.net Wed Aug 22 20:44:33 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Wed, 22 Aug 2012 13:44:33 -0700 Subject: [armedbear-cvs] r14132 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Aug 22 13:44:30 2012 New Revision: 14132 Log: Make Symbol.toString() print something developer-readable to help debugging in NetBeans. Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java Tue Aug 21 07:00:13 2012 (r14131) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Wed Aug 22 13:44:30 2012 (r14132) @@ -942,6 +942,19 @@ return this; } } + + @Override + public String toString() { + StringBuilder sb = new StringBuilder(); + if (pkg instanceof Package) { + sb.append(((Package)pkg).getName()); + sb.append(":"); + } else { + sb.append("#:"); + } + sb.append(name); + return sb.toString(); + } // External symbols in CL package. From ehuelsmann at common-lisp.net Wed Aug 22 21:37:01 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Wed, 22 Aug 2012 14:37:01 -0700 Subject: [armedbear-cvs] r14133 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Aug 22 14:36:59 2012 New Revision: 14133 Log: Remove code duplication. Rename MAKE-EXPANDER-FOR-MACROLET because it is no longer used solely for MACROLET. Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/autoloads-gen.lisp trunk/abcl/src/org/armedbear/lisp/compile-file.lisp trunk/abcl/src/org/armedbear/lisp/destructuring-bind.lisp trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java Wed Aug 22 13:44:30 2012 (r14132) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Wed Aug 22 14:36:59 2012 (r14133) @@ -1879,25 +1879,8 @@ public LispObject execute(LispObject args, Environment env) { - /* Create an expansion function - * `(lambda (,formArg ,envArg) - * (apply (function (macro-function ,lambdaList - * (block ,symbol , at body))) - * (cdr ,formArg))) - */ Symbol symbol = checkSymbol(args.car()); - LispObject lambdaList = checkList(args.cadr()); - LispObject body = args.cddr(); - LispObject block = new Cons(Symbol.BLOCK, new Cons(symbol, body)); - LispObject toBeApplied = - list(Symbol.FUNCTION, list(Symbol.MACRO_FUNCTION, lambdaList, block)); - final LispThread thread = LispThread.currentThread(); - LispObject formArg = gensym("FORM-", thread); - LispObject envArg = gensym("ENV-", thread); // Ignored. - LispObject expander = - list(Symbol.LAMBDA, list(formArg, envArg), - list(Symbol.APPLY, toBeApplied, - list(Symbol.CDR, formArg))); + LispObject expander = MAKE_MACRO_EXPANDER.execute(args); Closure expansionFunction = new Closure(expander, env); MacroObject macroObject = new MacroObject(symbol, expansionFunction); @@ -3634,7 +3617,7 @@ LispObject def = checkList(defs.car()); Symbol symbol = checkSymbol(def.car()); Symbol make_expander_for_macrolet = - PACKAGE_SYS.intern("MAKE-EXPANDER-FOR-MACROLET"); + PACKAGE_SYS.intern("MAKE-MACRO-EXPANDER"); LispObject expander = make_expander_for_macrolet.execute(def); Closure expansionFunction = new Closure(expander, env); @@ -3651,11 +3634,10 @@ } }; - private static final Primitive MAKE_EXPANDER_FOR_MACROLET = new pf_make_expander_for_macrolet(); - private static final class pf_make_expander_for_macrolet extends Primitive { - pf_make_expander_for_macrolet() { - super("make-expander-for-macrolet", PACKAGE_SYS, true, - "definition"); + private static final Primitive MAKE_MACRO_EXPANDER = new pf_make_macro_expander(); + private static final class pf_make_macro_expander extends Primitive { + pf_make_macro_expander() { + super("make-macro-expander", PACKAGE_SYS, true, "definition"); } @Override Modified: trunk/abcl/src/org/armedbear/lisp/autoloads-gen.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads-gen.lisp Wed Aug 22 13:44:30 2012 (r14132) +++ trunk/abcl/src/org/armedbear/lisp/autoloads-gen.lisp Wed Aug 22 14:36:59 2012 (r14133) @@ -150,7 +150,7 @@ ;; FUNCTIONS (IN-PACKAGE :SYSTEM) -(DOLIST (FS (QUOTE ((("abcl-contrib") FIND-SYSTEM-JAR FIND-CONTRIB) (("assert") ASSERT-ERROR ASSERT-PROMPT) (("aver") %FAILED-AVER) (("backquote") BACKQUOTE-MACRO COMMA-MACRO EXPANDABLE-BACKQ-EXPRESSION-P BACKQUOTIFY COMMA BACKQUOTIFY-1 BACKQ-LIST BACKQ-LIST* BACKQ-APPEND BACKQ-NCONC BACKQ-CONS BACKQ-VECTOR %READER-ERROR) (("bit-array-ops") BIT-ARRAY-SAME-DIMENSIONS-P REQUIRE-SAME-DIMENSIONS PICK-RESULT-ARRAY) (("case") LIST-OF-LENGTH-AT-LEAST-P CASE-BODY-ERROR CASE-BODY-AUX CASE-BODY) (("check-type") CHECK-TYPE-ERROR) (("clos") COERCE-TO-CONDITION) (("coerce") COERCE-LIST-TO-VECTOR COPY-STRING COERCE-ERROR COERCE-OBJECT-TO-AND-TYPE) (("compile-file-pathname") CFP-OUTPUT-FILE-DEFAULT) (("compile-file") BASE-CLASSNAME FASL-LOADER-CLASSNAME COMPUTE-CLASSFILE-NAME SANITIZE-CLASS-NAME NEXT-CLASSFILE-NAME DUMMY VERIFY-LOAD NOTE-TOPLEVEL-FORM OUTPUT-FORM FINALIZE-FASL-OUTPUT SIMPLE-TOPLEVEL-FORM-P CONVERT-TOPLEVEL-FORM PROCESS-PROGN PRECOMPILE-TOPLEVEL-FORM PROCESS-TOPLEVEL-MACROLET PROCESS-TOPLEVEL-DEFCONSTANT PROCESS-TOPLEVEL-QUOTE PROCESS-TOPLEVEL-IMPORT PROCESS-TOPLEVEL-EXPORT PROCESS-TOPLEVEL-MOP.ENSURE-METHOD PROCESS-TOPLEVEL-DEFVAR/DEFPARAMETER PROCESS-TOPLEVEL-DEFPACKAGE/IN-PACKAGE PROCESS-TOPLEVEL-DECLARE PROCESS-TOPLEVEL-PROGN PROCESS-TOPLEVEL-DEFTYPE PROCESS-TOPLEVEL-EVAL-WHEN PROCESS-TOPLEVEL-DEFMETHOD/DEFGENERIC PROCESS-TOPLEVEL-LOCALLY PROCESS-TOPLEVEL-DEFMACRO PROCESS-TOPLEVEL-DEFUN INSTALL-TOPLEVEL-HANDLER PROCESS-TOPLEVEL-FORM POPULATE-ZIP-FASL WRITE-FASL-PROLOGUE COMPILE-FROM-STREAM COMPILE-FILE-IF-NEEDED) (("compile-system") CHECK-LISP-HOME GROVEL-JAVA-DEFINITIONS-IN-FILE GROVEL-JAVA-DEFINITIONS PACKAGES-FROM-COMBOS REMOVE-MULTI-COMBO-SYMBOLS SET-EQUAL COMBOS-TO-SYMBOL-FILESETS COMBOS-TO-FILESET-SYMBOLS WRITE-AUTOLOADER WRITE-PACKAGE-FILESETS LOAD-COMBOS GENERATE-AUTOLOADS %COMPILE-SYSTEM CREATE-SYSTEM-LOGICAL-TRANSLATIONS) (("compiler-error") COMPILER-STYLE-WARN COMPILER-WARN COMPILER-ERROR INTERNAL-COMPILER-ERROR COMPILER-UNSUPPORTED) (("compiler-macro") COMPILER-MACROEXPAND-1 COMPILER-MACROEXPAND) (("compiler-pass2") AUTOCOMPILE) (("compiler-types") MAKE-CONSTANT-TYPE CONSTANT-TYPE-P %MAKE-INTEGER-TYPE INTEGER-TYPE-P MAKE-INTEGER-TYPE FIXNUM-TYPE-P FIXNUM-CONSTANT-VALUE INTEGER-CONSTANT-VALUE JAVA-LONG-TYPE-P MAKE-UNION-TYPE MAKE-COMPILER-TYPE INTEGER-TYPE-SUBTYPEP COMPILER-SUBTYPEP FUNCTION-RESULT-TYPE SET-FUNCTION-RESULT-TYPE %DEFKNOWN) (("concatenate") CONCATENATE-TO-STRING) (("debug") INTERNAL-DEBUG DEBUG-LOOP INVOKE-DEBUGGER-REPORT-CONDITION RUN-HOOK BACKTRACE-AS-LIST) (("define-symbol-macro") %DEFINE-SYMBOL-MACRO) (("defpackage") DESIGNATED-PACKAGE-NAME STRINGIFY-NAMES CHECK-DISJOINT) (("defsetf") %DEFSETF) (("defstruct") MAKE-DEFSTRUCT-DESCRIPTION MAKE-DEFSTRUCT-SLOT-DESCRIPTION KEYWORDIFY DEFINE-KEYWORD-CONSTRUCTOR FIND-DSD GET-SLOT DEFINE-BOA-CONSTRUCTOR DEFAULT-CONSTRUCTOR-NAME DEFINE-CONSTRUCTORS NAME-INDEX DEFINE-PREDICATE MAKE-LIST-READER MAKE-VECTOR-READER MAKE-STRUCTURE-READER DEFINE-READER MAKE-LIST-WRITER MAKE-VECTOR-WRITER MAKE-STRUCTURE-WRITER DEFINE-WRITER DEFINE-ACCESS-FUNCTIONS DEFINE-COPIER DEFINE-PRINT-FUNCTION PARSE-1-OPTION PARSE-NAME-AND-OPTIONS COMPILER-DEFSTRUCT DEFSTRUCT-DEFAULT-CONSTRUCTOR) (("deftype") EXPAND-DEFTYPE) (("delete-duplicates") LIST-DELETE-DUPLICATES* VECTOR-DELETE-DUPLICATES*) (("describe-compiler-policy") DESCRIBE-COMPILER-POLICY) (("describe") DESCRIBE-ARGLIST %DESCRIBE-OBJECT) (("destructuring-bind") PARSE-BODY ARG-COUNT-ERROR PARSE-DEFMACRO DEFMACRO-ERROR VERIFY-KEYWORDS LOOKUP-KEYWORD KEYWORD-SUPPLIED-P PARSE-DEFMACRO-LAMBDA-LIST PUSH-SUB-LIST-BINDING PUSH-LET-BINDING PUSH-OPTIONAL-BINDING MAKE-EXPANDER-FOR-MACROLET) (("directory") PATHNAME-AS-FILE WILD-INFERIORS-P LIST-DIRECTORIES-WITH-WILDCARDS) (("do") DO-DO-BODY) (("dump-form") GET-INSTANCE-FORM DF-REGISTER-CIRCULARITY DF-CHECK-CONS DF-CHECK-VECTOR DF-CHECK-INSTANCE DF-CHECK-OBJECT DF-HANDLE-CIRCULARITY DUMP-CONS DUMP-VECTOR DUMP-INSTANCE DUMP-UNINTERNED-SYMBOL-INDEX DUMP-OBJECT DUMP-FORM) (("ed") DEFAULT-ED-FUNCTION) (("enough-namestring") EQUAL-COMPONENTS-P) (("fill") LIST-FILL VECTOR-FILL) (("find") LIST-POSITION* VECTOR-POSITION* LIST-FIND* VECTOR-FIND*) (("format") SYMBOLICATE PROPER-LIST-OF-LENGTH-P FLONUM-TO-STRING ROUND-UP SCALE-EXPONENT FLOAT-DENORMALIZED-P) (("inline") INLINE-EXPANSION SET-INLINE-EXPANSION) (("inspect") LEADER SAFE-LENGTH DISPLAY-OBJECT DISPLAY-CURRENT ISTEP) (("late-setf") MAKE-GENSYM-LIST) (("lcm") TWO-ARG-LCM) (("ldb") %LDB) (("load") LOAD-RETURNING-LAST-RESULT) (("make-sequence") SIZE-MISMATCH-ERROR) (("map1") MAP1) (("nsubstitute") NLIST-SUBSTITUTE* NVECTOR-SUBSTITUTE* NLIST-SUBSTITUTE-IF* NVECTOR-SUBSTITUTE-IF* NLIST-SUBSTITUTE-IF-NOT* NVECTOR-SUBSTITUTE-IF-NOT*) (("open") UPGRADED-ELEMENT-TYPE-BITS UPGRADED-ELEMENT-TYPE) (("parse-integer") PARSE-INTEGER-ERROR) (("parse-lambda-list") PARSE-LAMBDA-LIST-LIKE-THING PARSE-LAMBDA-LIST) (("pathnames") COMPONENT-MATCH-WILD-P COMPONENT-MATCH-P DIRECTORY-MATCH-COMPONENTS DIRECTORY-MATCH-P WILD-P CASIFY TRANSLATE-COMPONENT TRANSLATE-JAR-DEVICE TRANSLATE-DIRECTORY-COMPONENTS-AUX TRANSLATE-DIRECTORY-COMPONENTS TRANSLATE-DIRECTORY LOGICAL-HOST-P CANONICALIZE-LOGICAL-PATHNAME-TRANSLATIONS %SET-LOGICAL-PATHNAME-TRANSLATIONS) (("print-unreadable-object") %PRINT-UNREADABLE-OBJECT) (("print") COMPOUND-OBJECT-P OUTPUT-INTEGER OUTPUT-LIST OUTPUT-TERSE-ARRAY ARRAY-READABLY-PRINTABLE-P OUTPUT-VECTOR OUTPUT-UGLY-OBJECT CHECK-FOR-CIRCULARITY HANDLE-CIRCULARITY PRINT-LABEL PRINT-REFERENCE UNIQUELY-IDENTIFIED-BY-PRINT-P %PRINT-OBJECT %CHECK-OBJECT OUTPUT-OBJECT) (("proclaim") DECLARATION-ERROR CHECK-DECLARATION-TYPE PROCLAIM-TYPE PROCLAIMED-TYPE PROCLAIM-FTYPE-1 PROCLAIM-FTYPE PROCLAIMED-FTYPE FTYPE-RESULT-TYPE) (("query") QUERY-READLINE) (("read-circle") CIRCLE-SUBST SHARP-EQUAL SHARP-SHARP) (("read-conditional") READ-FEATURE READ-CONDITIONAL) (("remove-duplicates") LIST-REMOVE-DUPLICATES VECTOR-REMOVE-DUPLICATES) (("replace") LIST-REPLACE-FROM-LIST* LIST-REPLACE-FROM-VECTOR* VECTOR-REPLACE-FROM-LIST* VECTOR-REPLACE-FROM-VECTOR*) (("run-program") RUN-PROGRAM %MAKE-PROCESS PROCESS-P MAKE-PROCESS PROCESS-ALIVE-P PROCESS-WAIT PROCESS-EXIT-CODE PROCESS-KILL %MAKE-PROCESS-BUILDER %PROCESS-BUILDER-ENVIRONMENT %PROCESS-BUILDER-ENV-PUT %PROCESS-BUILDER-ENV-CLEAR %PROCESS-BUILDER-START %MAKE-PROCESS-INPUT-STREAM %MAKE-PROCESS-OUTPUT-STREAM %MAKE-PROCESS-ERROR-STREAM %PROCESS-ALIVE-P %PROCESS-WAIT %PROCESS-EXIT-CODE %PROCESS-KILL) (("search") SIMPLE-SEARCH) (("sequences") MAKE-SEQUENCE-OF-TYPE) (("setf") GET-SETF-METHOD-INVERSE EXPAND-OR-GET-SETF-INVERSE %SET-SUBSEQ %DEFINE-SETF-MACRO %SET-CAAR %SET-CADR %SET-CDAR %SET-CDDR %SET-CAAAR %SET-CADAR %SET-CDAAR %SET-CDDAR %SET-CAADR %SET-CADDR %SET-CDADR %SET-CDDDR %SET-CAAAAR %SET-CADAAR %SET-CDAAAR %SET-CDDAAR %SET-CAADAR %SET-CADDAR %SET-CDADAR %SET-CDDDAR %SET-CAAADR %SET-CADADR %SET-CDAADR %SET-CDDADR %SET-CAADDR %SET-CADDDR %SET-CDADDR %SET-CDDDDR %SET-FIFTH %SET-SIXTH %SET-SEVENTH %SET-EIGHTH %SET-NINTH %SET-TENTH) (("sort") MERGE-SORT-VECTORS LAST-CONS-OF MERGE-LISTS MERGE-LISTS-NO-KEY SORT-LIST QUICKSORT QUICK-SORT) (("source-transform") SOURCE-TRANSFORM SET-SOURCE-TRANSFORM EXPAND-SOURCE-TRANSFORM-1 EXPAND-SOURCE-TRANSFORM) (("subst") %SUBST %SUBST-IF %SUBST-IF-NOT) (("subtypep") INITIALIZE-KNOWN-TYPES KNOWN-TYPE-P SUB-INTERVAL-P DIMENSION-SUBTYPEP SIMPLE-SUBTYPEP MAKE-CTYPE CTYPE-SUPER CTYPE-TYPE CTYPE CSUBTYPEP-ARRAY CSUBTYPEP-FUNCTION CSUBTYPEP-COMPLEX CSUBTYPEP %SUBTYPEP) (("time") PICK-OBVIOUS-YEAR LEAP-YEARS-BEFORE) (("trace") MAKE-TRACE-INFO TRACE-INFO-P LIST-TRACED-FUNCTIONS EXPAND-TRACE TRACE-1 TRACED-FUNCTION UNTRACED-FUNCTION TRACE-REDEFINED-UPDATE INDENT UNTRACE-ALL UNTRACE-1) (("tree-equal") TREE-EQUAL-TEST-NOT TREE-EQUAL-TEST) (("typep") SIMPLE-ARRAY-P IN-INTERVAL-P MATCH-DIMENSIONS %TYPEP) (("with-hash-table-iterator") HASH-TABLE-ITERATOR-FUNCTION) (("with-package-iterator") PACKAGE-ITERATOR-FUNCTION) (("with-standard-io-syntax") %WITH-STANDARD-IO-SYNTAX)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR FS) (CAR (CAR FS)))) +(DOLIST (FS (QUOTE ((("abcl-contrib") FIND-SYSTEM-JAR FIND-CONTRIB) (("assert") ASSERT-ERROR ASSERT-PROMPT) (("aver") %FAILED-AVER) (("backquote") BACKQUOTE-MACRO COMMA-MACRO EXPANDABLE-BACKQ-EXPRESSION-P BACKQUOTIFY COMMA BACKQUOTIFY-1 BACKQ-LIST BACKQ-LIST* BACKQ-APPEND BACKQ-NCONC BACKQ-CONS BACKQ-VECTOR %READER-ERROR) (("bit-array-ops") BIT-ARRAY-SAME-DIMENSIONS-P REQUIRE-SAME-DIMENSIONS PICK-RESULT-ARRAY) (("case") LIST-OF-LENGTH-AT-LEAST-P CASE-BODY-ERROR CASE-BODY-AUX CASE-BODY) (("check-type") CHECK-TYPE-ERROR) (("clos") COERCE-TO-CONDITION) (("coerce") COERCE-LIST-TO-VECTOR COPY-STRING COERCE-ERROR COERCE-OBJECT-TO-AND-TYPE) (("compile-file-pathname") CFP-OUTPUT-FILE-DEFAULT) (("compile-file") BASE-CLASSNAME FASL-LOADER-CLASSNAME COMPUTE-CLASSFILE-NAME SANITIZE-CLASS-NAME NEXT-CLASSFILE-NAME DUMMY VERIFY-LOAD NOTE-TOPLEVEL-FORM OUTPUT-FORM FINALIZE-FASL-OUTPUT SIMPLE-TOPLEVEL-FORM-P CONVERT-TOPLEVEL-FORM PROCESS-PROGN PRECOMPILE-TOPLEVEL-FORM PROCESS-TOPLEVEL-MACROLET PROCESS-TOPLEVEL-DEFCONSTANT PROCESS-TOPLEVEL-QUOTE PROCESS-TOPLEVEL-IMPORT PROCESS-TOPLEVEL-EXPORT PROCESS-TOPLEVEL-MOP.ENSURE-METHOD PROCESS-TOPLEVEL-DEFVAR/DEFPARAMETER PROCESS-TOPLEVEL-DEFPACKAGE/IN-PACKAGE PROCESS-TOPLEVEL-DECLARE PROCESS-TOPLEVEL-PROGN PROCESS-TOPLEVEL-DEFTYPE PROCESS-TOPLEVEL-EVAL-WHEN PROCESS-TOPLEVEL-DEFMETHOD/DEFGENERIC PROCESS-TOPLEVEL-LOCALLY PROCESS-TOPLEVEL-DEFMACRO PROCESS-TOPLEVEL-DEFUN INSTALL-TOPLEVEL-HANDLER PROCESS-TOPLEVEL-FORM POPULATE-ZIP-FASL WRITE-FASL-PROLOGUE COMPILE-FROM-STREAM COMPILE-FILE-IF-NEEDED) (("compile-system") CHECK-LISP-HOME GROVEL-JAVA-DEFINITIONS-IN-FILE GROVEL-JAVA-DEFINITIONS PACKAGES-FROM-COMBOS REMOVE-MULTI-COMBO-SYMBOLS SET-EQUAL COMBOS-TO-SYMBOL-FILESETS COMBOS-TO-FILESET-SYMBOLS WRITE-AUTOLOADER WRITE-PACKAGE-FILESETS LOAD-COMBOS GENERATE-AUTOLOADS %COMPILE-SYSTEM CREATE-SYSTEM-LOGICAL-TRANSLATIONS) (("compiler-error") COMPILER-STYLE-WARN COMPILER-WARN COMPILER-ERROR INTERNAL-COMPILER-ERROR COMPILER-UNSUPPORTED) (("compiler-macro") COMPILER-MACROEXPAND-1 COMPILER-MACROEXPAND) (("compiler-pass2") AUTOCOMPILE) (("compiler-types") MAKE-CONSTANT-TYPE CONSTANT-TYPE-P %MAKE-INTEGER-TYPE INTEGER-TYPE-P MAKE-INTEGER-TYPE FIXNUM-TYPE-P FIXNUM-CONSTANT-VALUE INTEGER-CONSTANT-VALUE JAVA-LONG-TYPE-P MAKE-UNION-TYPE MAKE-COMPILER-TYPE INTEGER-TYPE-SUBTYPEP COMPILER-SUBTYPEP FUNCTION-RESULT-TYPE SET-FUNCTION-RESULT-TYPE %DEFKNOWN) (("concatenate") CONCATENATE-TO-STRING) (("debug") INTERNAL-DEBUG DEBUG-LOOP INVOKE-DEBUGGER-REPORT-CONDITION RUN-HOOK BACKTRACE-AS-LIST) (("define-symbol-macro") %DEFINE-SYMBOL-MACRO) (("defpackage") DESIGNATED-PACKAGE-NAME STRINGIFY-NAMES CHECK-DISJOINT) (("defsetf") %DEFSETF) (("defstruct") MAKE-DEFSTRUCT-DESCRIPTION MAKE-DEFSTRUCT-SLOT-DESCRIPTION KEYWORDIFY DEFINE-KEYWORD-CONSTRUCTOR FIND-DSD GET-SLOT DEFINE-BOA-CONSTRUCTOR DEFAULT-CONSTRUCTOR-NAME DEFINE-CONSTRUCTORS NAME-INDEX DEFINE-PREDICATE MAKE-LIST-READER MAKE-VECTOR-READER MAKE-STRUCTURE-READER DEFINE-READER MAKE-LIST-WRITER MAKE-VECTOR-WRITER MAKE-STRUCTURE-WRITER DEFINE-WRITER DEFINE-ACCESS-FUNCTIONS DEFINE-COPIER DEFINE-PRINT-FUNCTION PARSE-1-OPTION PARSE-NAME-AND-OPTIONS COMPILER-DEFSTRUCT DEFSTRUCT-DEFAULT-CONSTRUCTOR) (("deftype") EXPAND-DEFTYPE) (("delete-duplicates") LIST-DELETE-DUPLICATES* VECTOR-DELETE-DUPLICATES*) (("describe-compiler-policy") DESCRIBE-COMPILER-POLICY) (("describe") DESCRIBE-ARGLIST %DESCRIBE-OBJECT) (("destructuring-bind") PARSE-BODY ARG-COUNT-ERROR PARSE-DEFMACRO DEFMACRO-ERROR VERIFY-KEYWORDS LOOKUP-KEYWORD KEYWORD-SUPPLIED-P PARSE-DEFMACRO-LAMBDA-LIST PUSH-SUB-LIST-BINDING PUSH-LET-BINDING PUSH-OPTIONAL-BINDING MAKE-MACRO-EXPANDER) (("directory") PATHNAME-AS-FILE WILD-INFERIORS-P LIST-DIRECTORIES-WITH-WILDCARDS) (("do") DO-DO-BODY) (("dump-form") GET-INSTANCE-FORM DF-REGISTER-CIRCULARITY DF-CHECK-CONS DF-CHECK-VECTOR DF-CHECK-INSTANCE DF-CHECK-OBJECT DF-HANDLE-CIRCULARITY DUMP-CONS DUMP-VECTOR DUMP-INSTANCE DUMP-UNINTERNED-SYMBOL-INDEX DUMP-OBJECT DUMP-FORM) (("ed") DEFAULT-ED-FUNCTION) (("enough-namestring") EQUAL-COMPONENTS-P) (("fill") LIST-FILL VECTOR-FILL) (("find") LIST-POSITION* VECTOR-POSITION* LIST-FIND* VECTOR-FIND*) (("format") SYMBOLICATE PROPER-LIST-OF-LENGTH-P FLONUM-TO-STRING ROUND-UP SCALE-EXPONENT FLOAT-DENORMALIZED-P) (("inline") INLINE-EXPANSION SET-INLINE-EXPANSION) (("inspect") LEADER SAFE-LENGTH DISPLAY-OBJECT DISPLAY-CURRENT ISTEP) (("late-setf") MAKE-GENSYM-LIST) (("lcm") TWO-ARG-LCM) (("ldb") %LDB) (("load") LOAD-RETURNING-LAST-RESULT) (("make-sequence") SIZE-MISMATCH-ERROR) (("map1") MAP1) (("nsubstitute") NLIST-SUBSTITUTE* NVECTOR-SUBSTITUTE* NLIST-SUBSTITUTE-IF* NVECTOR-SUBSTITUTE-IF* NLIST-SUBSTITUTE-IF-NOT* NVECTOR-SUBSTITUTE-IF-NOT*) (("open") UPGRADED-ELEMENT-TYPE-BITS UPGRADED-ELEMENT-TYPE) (("parse-integer") PARSE-INTEGER-ERROR) (("parse-lambda-list") PARSE-LAMBDA-LIST-LIKE-THING PARSE-LAMBDA-LIST) (("pathnames") COMPONENT-MATCH-WILD-P COMPONENT-MATCH-P DIRECTORY-MATCH-COMPONENTS DIRECTORY-MATCH-P WILD-P CASIFY TRANSLATE-COMPONENT TRANSLATE-JAR-DEVICE TRANSLATE-DIRECTORY-COMPONENTS-AUX TRANSLATE-DIRECTORY-COMPONENTS TRANSLATE-DIRECTORY LOGICAL-HOST-P CANONICALIZE-LOGICAL-PATHNAME-TRANSLATIONS %SET-LOGICAL-PATHNAME-TRANSLATIONS) (("print-unreadable-object") %PRINT-UNREADABLE-OBJECT) (("print") COMPOUND-OBJECT-P OUTPUT-INTEGER OUTPUT-LIST OUTPUT-TERSE-ARRAY ARRAY-READABLY-PRINTABLE-P OUTPUT-VECTOR OUTPUT-UGLY-OBJECT CHECK-FOR-CIRCULARITY HANDLE-CIRCULARITY PRINT-LABEL PRINT-REFERENCE UNIQUELY-IDENTIFIED-BY-PRINT-P %PRINT-OBJECT %CHECK-OBJECT OUTPUT-OBJECT) (("proclaim") DECLARATION-ERROR CHECK-DECLARATION-TYPE PROCLAIM-TYPE PROCLAIMED-TYPE PROCLAIM-FTYPE-1 PROCLAIM-FTYPE PROCLAIMED-FTYPE FTYPE-RESULT-TYPE) (("query") QUERY-READLINE) (("read-circle") CIRCLE-SUBST SHARP-EQUAL SHARP-SHARP) (("read-conditional") READ-FEATURE READ-CONDITIONAL) (("remove-duplicates") LIST-REMOVE-DUPLICATES VECTOR-REMOVE-DUPLICATES) (("replace") LIST-REPLACE-FROM-LIST* LIST-REPLACE-FROM-VECTOR* VECTOR-REPLACE-FROM-LIST* VECTOR-REPLACE-FROM-VECTOR*) (("run-program") RUN-PROGRAM %MAKE-PROCESS PROCESS-P MAKE-PROCESS PROCESS-ALIVE-P PROCESS-WAIT PROCESS-EXIT-CODE PROCESS-KILL %MAKE-PROCESS-BUILDER %PROCESS-BUILDER-ENVIRONMENT %PROCESS-BUILDER-ENV-PUT %PROCESS-BUILDER-ENV-CLEAR %PROCESS-BUILDER-START %MAKE-PROCESS-INPUT-STREAM %MAKE-PROCESS-OUTPUT-STREAM %MAKE-PROCESS-ERROR-STREAM %PROCESS-ALIVE-P %PROCESS-WAIT %PROCESS-EXIT-CODE %PROCESS-KILL) (("search") SIMPLE-SEARCH) (("sequences") MAKE-SEQUENCE-OF-TYPE) (("setf") GET-SETF-METHOD-INVERSE EXPAND-OR-GET-SETF-INVERSE %SET-SUBSEQ %DEFINE-SETF-MACRO %SET-CAAR %SET-CADR %SET-CDAR %SET-CDDR %SET-CAAAR %SET-CADAR %SET-CDAAR %SET-CDDAR %SET-CAADR %SET-CADDR %SET-CDADR %SET-CDDDR %SET-CAAAAR %SET-CADAAR %SET-CDAAAR %SET-CDDAAR %SET-CAADAR %SET-CADDAR %SET-CDADAR %SET-CDDDAR %SET-CAAADR %SET-CADADR %SET-CDAADR %SET-CDDADR %SET-CAADDR %SET-CADDDR %SET-CDADDR %SET-CDDDDR %SET-FIFTH %SET-SIXTH %SET-SEVENTH %SET-EIGHTH %SET-NINTH %SET-TENTH) (("sort") MERGE-SORT-VECTORS LAST-CONS-OF MERGE-LISTS MERGE-LISTS-NO-KEY SORT-LIST QUICKSORT QUICK-SORT) (("source-transform") SOURCE-TRANSFORM SET-SOURCE-TRANSFORM EXPAND-SOURCE-TRANSFORM-1 EXPAND-SOURCE-TRANSFORM) (("subst") %SUBST %SUBST-IF %SUBST-IF-NOT) (("subtypep") INITIALIZE-KNOWN-TYPES KNOWN-TYPE-P SUB-INTERVAL-P DIMENSION-SUBTYPEP SIMPLE-SUBTYPEP MAKE-CTYPE CTYPE-SUPER CTYPE-TYPE CTYPE CSUBTYPEP-ARRAY CSUBTYPEP-FUNCTION CSUBTYPEP-COMPLEX CSUBTYPEP %SUBTYPEP) (("time") PICK-OBVIOUS-YEAR LEAP-YEARS-BEFORE) (("trace") MAKE-TRACE-INFO TRACE-INFO-P LIST-TRACED-FUNCTIONS EXPAND-TRACE TRACE-1 TRACED-FUNCTION UNTRACED-FUNCTION TRACE-REDEFINED-UPDATE INDENT UNTRACE-ALL UNTRACE-1) (("tree-equal") TREE-EQUAL-TEST-NOT TREE-EQUAL-TEST) (("typep") SIMPLE-ARRAY-P IN-INTERVAL-P MATCH-DIMENSIONS %TYPEP) (("with-hash-table-iterator") HASH-TABLE-ITERATOR-FUNCTION) (("with-package-iterator") PACKAGE-ITERATOR-FUNCTION) (("with-standard-io-syntax") %WITH-STANDARD-IO-SYNTAX)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR FS) (CAR (CAR FS)))) ;; MACROS Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Wed Aug 22 13:44:30 2012 (r14132) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Wed Aug 22 14:36:59 2012 (r14133) @@ -247,7 +247,7 @@ (environment-add-macro-definition *compile-file-environment* (car definition) (make-macro (car definition) - (make-expander-for-macrolet definition)))) + (make-macro-expander definition)))) (dolist (body-form (cddr form)) (process-toplevel-form body-form stream compile-time-too))) nil) Modified: trunk/abcl/src/org/armedbear/lisp/destructuring-bind.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/destructuring-bind.lisp Wed Aug 22 13:44:30 2012 (r14132) +++ trunk/abcl/src/org/armedbear/lisp/destructuring-bind.lisp Wed Aug 22 14:36:59 2012 (r14133) @@ -368,8 +368,8 @@ , at local-decls ,body)))) -;; Redefine SYS:MAKE-EXPANDER-FOR-MACROLET to use PARSE-DEFMACRO. -(defun make-expander-for-macrolet (definition) +;; Redefine SYS:MAKE-MACRO-EXPANDER to use PARSE-DEFMACRO. +(defun make-macro-expander (definition) (let* ((name (car definition)) (lambda-list (cadr definition)) (form (gensym "WHOLE-")) Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Wed Aug 22 13:44:30 2012 (r14132) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Wed Aug 22 14:36:59 2012 (r14133) @@ -647,7 +647,7 @@ (car definition) (make-macro (car definition) (make-closure - (make-expander-for-macrolet definition) + (make-macro-expander definition) NIL)))) (multiple-value-bind (body decls) (parse-body (cddr form) nil) From rschlatte at common-lisp.net Sat Aug 25 21:14:51 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sat, 25 Aug 2012 14:14:51 -0700 Subject: [armedbear-cvs] r14134 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sat Aug 25 14:14:49 2012 New Revision: 14134 Log: Handle instances of subclasses of standard-slot-definition in accessors - Subclasses of standard-(direct|effective)-slot-definition are of Java class StandardObject and might have different class layout. - Keep the fast, fixed-indexing path for objects of Java class SlotDefinition, handle other objects via slot-name-based indexing. - Thanks to Stas Boukarev and Pascal Costanza for error reports and diagnosis. Modified: trunk/abcl/src/org/armedbear/lisp/SlotClass.java trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java trunk/abcl/src/org/armedbear/lisp/SlotDefinitionClass.java trunk/abcl/src/org/armedbear/lisp/Symbol.java Modified: trunk/abcl/src/org/armedbear/lisp/SlotClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlotClass.java Wed Aug 22 14:36:59 2012 (r14133) +++ trunk/abcl/src/org/armedbear/lisp/SlotClass.java Sat Aug 25 14:14:49 2012 (r14134) @@ -170,8 +170,10 @@ LispObject tail = getSlotDefinitions(); while (tail != NIL) { SlotDefinition slotDefinition = (SlotDefinition) tail.car(); - slotDefinition.setLocation(i); - instanceSlotNames[i++] = slotDefinition.getName(); + SlotDefinition.SET_SLOT_DEFINITION_LOCATION + .execute(slotDefinition, Fixnum.getInstance(i)); + instanceSlotNames[i++] = SlotDefinition._SLOT_DEFINITION_NAME + .execute(slotDefinition); tail = tail.cdr(); } setClassLayout(new Layout(this, instanceSlotNames, NIL)); Modified: trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java Wed Aug 22 14:36:59 2012 (r14133) +++ trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java Sat Aug 25 14:14:49 2012 (r14134) @@ -47,11 +47,15 @@ } public SlotDefinition(StandardClass clazz) { + // clazz layout needs to have SlotDefinitionClass layout as prefix + // or indexed slot access won't work super(clazz, clazz.getClassLayout().getLength()); slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL; } public SlotDefinition(StandardClass clazz, LispObject name) { + // clazz layout needs to have SlotDefinitionClass layout as prefix + // or indexed slot access won't work super(clazz, clazz.getClassLayout().getLength()); slots[SlotDefinitionClass.SLOT_INDEX_NAME] = name; slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = NIL; @@ -118,18 +122,8 @@ } public static StandardObject checkSlotDefinition(LispObject obj) { - if (obj instanceof StandardObject) return (StandardObject)obj; - return (StandardObject)type_error(obj, Symbol.SLOT_DEFINITION); - } - - public final LispObject getName() - { - return slots[SlotDefinitionClass.SLOT_INDEX_NAME]; - } - - public final void setLocation(int i) - { - slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = Fixnum.getInstance(i); + if (obj instanceof StandardObject) return (StandardObject)obj; + return (StandardObject)type_error(obj, Symbol.SLOT_DEFINITION); } @Override @@ -149,7 +143,8 @@ private static final Primitive MAKE_SLOT_DEFINITION = new pf_make_slot_definition(); @DocString(name="make-slot-definition", - args="&optional class") + args="&optional class", + doc="Cannot be called with user-defined subclasses of standard-slot-definition.") private static final class pf_make_slot_definition extends Primitive { pf_make_slot_definition() @@ -168,7 +163,7 @@ } }; - private static final Primitive _SLOT_DEFINITION_NAME + static final Primitive _SLOT_DEFINITION_NAME = new pf__slot_definition_name(); @DocString(name="%slot-definition-name") private static final class pf__slot_definition_name extends Primitive @@ -180,7 +175,11 @@ @Override public LispObject execute(LispObject arg) { - return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_NAME]; + StandardObject o = checkSlotDefinition(arg); + if (o instanceof SlotDefinition) + return o.slots[SlotDefinitionClass.SLOT_INDEX_NAME]; + else + return o.getInstanceSlotValue(Symbol.NAME); } }; @@ -198,7 +197,11 @@ @Override public LispObject execute(LispObject first, LispObject second) { - checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_NAME] = second; + StandardObject o = checkSlotDefinition(first); + if (o instanceof SlotDefinition) + o.slots[SlotDefinitionClass.SLOT_INDEX_NAME] = second; + else + o.setInstanceSlotValue(Symbol.NAME, second); return second; } }; @@ -215,7 +218,11 @@ @Override public LispObject execute(LispObject arg) { - return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION]; + StandardObject o = checkSlotDefinition(arg); + if (o instanceof SlotDefinition) + return o.slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION]; + else + return o.getInstanceSlotValue(Symbol.INITFUNCTION); } }; @@ -233,7 +240,11 @@ @Override public LispObject execute(LispObject first, LispObject second) { - checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = second; + StandardObject o = checkSlotDefinition(first); + if (o instanceof SlotDefinition) + o.slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = second; + else + o.setInstanceSlotValue(Symbol.INITFUNCTION, second); return second; } }; @@ -246,13 +257,16 @@ { pf__slot_definition_initform() { - super("%slot-definition-initform", PACKAGE_SYS, true, - "slot-definition"); + super("%slot-definition-initform", PACKAGE_SYS, true, "slot-definition"); } @Override public LispObject execute(LispObject arg) { - return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM]; + StandardObject o = checkSlotDefinition(arg); + if (o instanceof SlotDefinition) + return o.slots[SlotDefinitionClass.SLOT_INDEX_INITFORM]; + else + return o.getInstanceSlotValue(Symbol.INITFORM); } }; @@ -270,7 +284,11 @@ @Override public LispObject execute(LispObject first, LispObject second) { - checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM] = second; + StandardObject o = checkSlotDefinition(first); + if (o instanceof SlotDefinition) + o.slots[SlotDefinitionClass.SLOT_INDEX_INITFORM] = second; + else + o.setInstanceSlotValue(Symbol.INITFORM, second); return second; } }; @@ -287,7 +305,11 @@ @Override public LispObject execute(LispObject arg) { - return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS]; + StandardObject o = checkSlotDefinition(arg); + if (o instanceof SlotDefinition) + return o.slots[SlotDefinitionClass.SLOT_INDEX_INITARGS]; + else + return o.getInstanceSlotValue(Symbol.INITARGS); } }; @@ -305,7 +327,11 @@ @Override public LispObject execute(LispObject first, LispObject second) { - checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS] = second; + StandardObject o = checkSlotDefinition(first); + if (o instanceof SlotDefinition) + o.slots[SlotDefinitionClass.SLOT_INDEX_INITARGS] = second; + else + o.setInstanceSlotValue(Symbol.INITARGS, second); return second; } }; @@ -323,7 +349,11 @@ @Override public LispObject execute(LispObject arg) { - return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_READERS]; + StandardObject o = checkSlotDefinition(arg); + if (o instanceof SlotDefinition) + return o.slots[SlotDefinitionClass.SLOT_INDEX_READERS]; + else + return o.getInstanceSlotValue(Symbol.READERS); } }; @@ -341,7 +371,11 @@ @Override public LispObject execute(LispObject first, LispObject second) { - checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_READERS] = second; + StandardObject o = checkSlotDefinition(first); + if (o instanceof SlotDefinition) + o.slots[SlotDefinitionClass.SLOT_INDEX_READERS] = second; + else + o.setInstanceSlotValue(Symbol.READERS, second); return second; } }; @@ -360,7 +394,11 @@ @Override public LispObject execute(LispObject arg) { - return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS]; + StandardObject o = checkSlotDefinition(arg); + if (o instanceof SlotDefinition) + return o.slots[SlotDefinitionClass.SLOT_INDEX_WRITERS]; + else + return o.getInstanceSlotValue(Symbol.WRITERS); } }; @@ -378,7 +416,11 @@ @Override public LispObject execute(LispObject first, LispObject second) { - checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS] = second; + StandardObject o = checkSlotDefinition(first); + if (o instanceof SlotDefinition) + o.slots[SlotDefinitionClass.SLOT_INDEX_WRITERS] = second; + else + o.setInstanceSlotValue(Symbol.WRITERS, second); return second; } }; @@ -397,7 +439,11 @@ @Override public LispObject execute(LispObject arg) { - return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION]; + StandardObject o = checkSlotDefinition(arg); + if (o instanceof SlotDefinition) + return o.slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION]; + else + return o.getInstanceSlotValue(Symbol.ALLOCATION); } }; @@ -415,7 +461,11 @@ @Override public LispObject execute(LispObject first, LispObject second) { - checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = second; + StandardObject o = checkSlotDefinition(first); + if (o instanceof SlotDefinition) + o.slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = second; + else + o.setInstanceSlotValue(Symbol.ALLOCATION, second); return second; } }; @@ -434,7 +484,11 @@ @Override public LispObject execute(LispObject arg) { - return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS]; + StandardObject o = checkSlotDefinition(arg); + if (o instanceof SlotDefinition) + return o.slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS]; + else + return o.getInstanceSlotValue(Symbol.ALLOCATION_CLASS); } }; @@ -452,7 +506,11 @@ @Override public LispObject execute(LispObject first, LispObject second) { - checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS] = second; + StandardObject o = checkSlotDefinition(first); + if (o instanceof SlotDefinition) + o.slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS] = second; + else + o.setInstanceSlotValue(Symbol.ALLOCATION_CLASS, second); return second; } }; @@ -469,11 +527,15 @@ @Override public LispObject execute(LispObject arg) { - return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION]; + StandardObject o = checkSlotDefinition(arg); + if (o instanceof SlotDefinition) + return o.slots[SlotDefinitionClass.SLOT_INDEX_LOCATION]; + else + return o.getInstanceSlotValue(Symbol.LOCATION); } }; - private static final Primitive SET_SLOT_DEFINITION_LOCATION + static final Primitive SET_SLOT_DEFINITION_LOCATION = new pf_set_slot_definition_location(); @DocString(name="set-slot-definition-location", args="slot-definition location") @@ -487,7 +549,11 @@ @Override public LispObject execute(LispObject first, LispObject second) { - checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = second; + StandardObject o = checkSlotDefinition(first); + if (o instanceof SlotDefinition) + o.slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = second; + else + o.setInstanceSlotValue(Symbol.LOCATION, second); return second; } }; @@ -504,7 +570,11 @@ @Override public LispObject execute(LispObject arg) { - return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_TYPE]; + StandardObject o = checkSlotDefinition(arg); + if (o instanceof SlotDefinition) + return o.slots[SlotDefinitionClass.SLOT_INDEX_TYPE]; + else + return o.getInstanceSlotValue(Symbol._TYPE); } }; @@ -522,7 +592,11 @@ @Override public LispObject execute(LispObject first, LispObject second) { - checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_TYPE] = second; + StandardObject o = checkSlotDefinition(first); + if (o instanceof SlotDefinition) + o.slots[SlotDefinitionClass.SLOT_INDEX_TYPE] = second; + else + o.setInstanceSlotValue(Symbol._TYPE, second); return second; } }; @@ -539,7 +613,11 @@ @Override public LispObject execute(LispObject arg) { - return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_DOCUMENTATION]; + StandardObject o = checkSlotDefinition(arg); + if (o instanceof SlotDefinition) + return o.slots[SlotDefinitionClass.SLOT_INDEX_DOCUMENTATION]; + else + return o.getInstanceSlotValue(Symbol._DOCUMENTATION); } }; @@ -557,7 +635,11 @@ @Override public LispObject execute(LispObject first, LispObject second) { - checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_DOCUMENTATION] = second; + StandardObject o = checkSlotDefinition(first); + if (o instanceof SlotDefinition) + o.slots[SlotDefinitionClass.SLOT_INDEX_DOCUMENTATION] = second; + else + o.setInstanceSlotValue(Symbol._DOCUMENTATION, second); return second; } }; Modified: trunk/abcl/src/org/armedbear/lisp/SlotDefinitionClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlotDefinitionClass.java Wed Aug 22 14:36:59 2012 (r14133) +++ trunk/abcl/src/org/armedbear/lisp/SlotDefinitionClass.java Sat Aug 25 14:14:49 2012 (r14134) @@ -50,22 +50,23 @@ public static final int SLOT_INDEX_DOCUMENTATION = 10; /** - * For internal use only. This constructor hardcodes the layout of the class, and can't be used - * to create arbitrary subclasses of slot-definition. + * For internal use only. This constructor hardcodes the layout of + * the class, and can't be used to create arbitrary subclasses of + * slot-definition since new slots get added at the beginning. */ public SlotDefinitionClass(Symbol symbol, LispObject cpl) { super(symbol, cpl); Package pkg = PACKAGE_SYS; LispObject[] instanceSlotNames = { - pkg.intern("NAME"), - pkg.intern("INITFUNCTION"), - pkg.intern("INITFORM"), - pkg.intern("INITARGS"), - pkg.intern("READERS"), - pkg.intern("WRITERS"), - pkg.intern("ALLOCATION"), - pkg.intern("ALLOCATION-CLASS"), - pkg.intern("LOCATION"), + Symbol.NAME, + Symbol.INITFUNCTION, + Symbol.INITFORM, + Symbol.INITARGS, + Symbol.READERS, + Symbol.WRITERS, + Symbol.ALLOCATION, + Symbol.ALLOCATION_CLASS, + Symbol.LOCATION, Symbol._TYPE, Symbol._DOCUMENTATION }; Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java Wed Aug 22 14:36:59 2012 (r14133) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Sat Aug 25 14:14:49 2012 (r14134) @@ -3110,6 +3110,10 @@ // Internal symbols in SYSTEM package. + public static final Symbol ALLOCATION = + PACKAGE_SYS.addInternalSymbol("ALLOCATION"); + public static final Symbol ALLOCATION_CLASS = + PACKAGE_SYS.addInternalSymbol("ALLOCATION-CLASS"); public static final Symbol BACKQUOTE_MACRO = PACKAGE_SYS.addInternalSymbol("BACKQUOTE-MACRO"); public static final Symbol CASE_FROB_STREAM = @@ -3137,10 +3141,24 @@ PACKAGE_SYS.addInternalSymbol("FUNCTION-PRELOAD"); public static final Symbol _GENERIC_FUNCTION = PACKAGE_SYS.addInternalSymbol("%GENERIC-FUNCTION"); + public static final Symbol INITARGS = + PACKAGE_SYS.addInternalSymbol("INITARGS"); + public static final Symbol INITFORM = + PACKAGE_SYS.addInternalSymbol("INITFORM"); + public static final Symbol INITFUNCTION = + PACKAGE_SYS.addInternalSymbol("INITFUNCTION"); public static final Symbol INSTANCE = PACKAGE_SYS.addInternalSymbol("INSTANCE"); + public static final Symbol JAVA_STACK_FRAME = + PACKAGE_SYS.addInternalSymbol("JAVA-STACK-FRAME"); public static final Symbol KEYWORDS = PACKAGE_SYS.addInternalSymbol("KEYWORDS"); + public static final Symbol LAMBDA_LIST = + PACKAGE_SYS.addInternalSymbol("LAMBDA-LIST"); + public static final Symbol LISP_STACK_FRAME = + PACKAGE_SYS.addInternalSymbol("LISP-STACK-FRAME"); + public static final Symbol LOCATION = + PACKAGE_SYS.addInternalSymbol("LOCATION"); public static final Symbol MACROEXPAND_MACRO = PACKAGE_SYS.addInternalSymbol("MACROEXPAND-MACRO"); public static final Symbol MAKE_FUNCTION_PRELOADING_CONTEXT = @@ -3157,6 +3175,8 @@ PACKAGE_SYS.addInternalSymbol("PROXY-PRELOADED-FUNCTION"); public static final Symbol QUALIFIERS = PACKAGE_SYS.addInternalSymbol("QUALIFIERS"); + public static final Symbol READERS = + PACKAGE_SYS.addInternalSymbol("READERS"); public static final Symbol _SOURCE = PACKAGE_SYS.addInternalSymbol("%SOURCE"); public static final Symbol SOCKET_STREAM = @@ -3173,12 +3193,8 @@ PACKAGE_SYS.addInternalSymbol("STACK-FRAME"); public static final Symbol _TYPE = PACKAGE_SYS.addInternalSymbol("%TYPE"); - public static final Symbol LISP_STACK_FRAME = - PACKAGE_SYS.addInternalSymbol("LISP-STACK-FRAME"); - public static final Symbol JAVA_STACK_FRAME = - PACKAGE_SYS.addInternalSymbol("JAVA-STACK-FRAME"); - public static final Symbol LAMBDA_LIST = - PACKAGE_SYS.addInternalSymbol("LAMBDA-LIST"); + public static final Symbol WRITERS = + PACKAGE_SYS.addInternalSymbol("WRITERS"); // CDR6 public static final Symbol _INSPECTOR_HOOK_ = From rschlatte at common-lisp.net Sun Aug 26 15:09:29 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 26 Aug 2012 08:09:29 -0700 Subject: [armedbear-cvs] r14135 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Aug 26 08:09:27 2012 New Revision: 14135 Log: Catch out-of-bounds exception in standard-instance-access - Reported by Pascal Costanza Modified: trunk/abcl/src/org/armedbear/lisp/StandardObject.java Modified: trunk/abcl/src/org/armedbear/lisp/StandardObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardObject.java Sat Aug 25 14:14:49 2012 (r14134) +++ trunk/abcl/src/org/armedbear/lisp/StandardObject.java Sun Aug 26 08:09:27 2012 (r14135) @@ -473,7 +473,23 @@ public LispObject execute(LispObject first, LispObject second, LispObject third) { - checkStandardObject(first).slots[Fixnum.getValue(second)] = third; // FIXME + final StandardObject instance = checkStandardObject(first); + final int index; + if (second instanceof Fixnum) { + index = ((Fixnum)second).value; + } else { + return type_error(second, + list(Symbol.INTEGER, Fixnum.ZERO, + Fixnum.getInstance(instance.slots.length))); + } + + try { + instance.slots[index] = third; + } catch (ArrayIndexOutOfBoundsException e) { + return type_error(second, + list(Symbol.INTEGER, Fixnum.ZERO, + Fixnum.getInstance(instance.slots.length))); + } return third; } }; From rschlatte at common-lisp.net Sun Aug 26 17:37:31 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 26 Aug 2012 10:37:31 -0700 Subject: [armedbear-cvs] r14136 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Aug 26 10:37:30 2012 New Revision: 14136 Log: Refine #14135: now with less misleading error message - The upper bound of the INTEGER type is inclusive - ask for an integer between 0 and n-1 - If the object has no slots at all, raise a program-error instead of a type-error - If the location argument has the wrong type, ask for an integer, not a more fancy type Modified: trunk/abcl/src/org/armedbear/lisp/StandardObject.java Modified: trunk/abcl/src/org/armedbear/lisp/StandardObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardObject.java Sun Aug 26 08:09:27 2012 (r14135) +++ trunk/abcl/src/org/armedbear/lisp/StandardObject.java Sun Aug 26 10:37:30 2012 (r14136) @@ -429,27 +429,26 @@ { final StandardObject instance = checkStandardObject(first); final int index; - if (second instanceof Fixnum) - { - index = ((Fixnum)second).value; - } - else - { - return type_error(second, - list(Symbol.INTEGER, Fixnum.ZERO, - Fixnum.getInstance(instance.slots.length))); - } + if (second instanceof Fixnum) { + index = ((Fixnum)second).value; + } else { + return type_error(second, Symbol.INTEGER); + } + LispObject value; - try - { - value = instance.slots[index]; - } - catch (ArrayIndexOutOfBoundsException e) - { + try { + value = instance.slots[index]; + } catch (ArrayIndexOutOfBoundsException e) { + if (instance.slots.length > 0) return type_error(second, list(Symbol.INTEGER, Fixnum.ZERO, - Fixnum.getInstance(instance.slots.length))); - } + Fixnum.getInstance(instance.slots.length - 1))); + else + return error(new ProgramError("The object " + + instance.princToString() + + " has no slots.")); + + } // We let UNBOUND_VALUE escape here, since invoking // standard-instance-access on an unbound slot has undefined // consequences (AMOP pg. 239), and we use this behavior to @@ -478,17 +477,20 @@ if (second instanceof Fixnum) { index = ((Fixnum)second).value; } else { - return type_error(second, - list(Symbol.INTEGER, Fixnum.ZERO, - Fixnum.getInstance(instance.slots.length))); + return type_error(second, Symbol.INTEGER); } - try { instance.slots[index] = third; } catch (ArrayIndexOutOfBoundsException e) { - return type_error(second, - list(Symbol.INTEGER, Fixnum.ZERO, - Fixnum.getInstance(instance.slots.length))); + if (instance.slots.length > 0) + return type_error(second, + list(Symbol.INTEGER, Fixnum.ZERO, + Fixnum.getInstance(instance.slots.length - 1))); + else + return error(new ProgramError("The object " + + instance.princToString() + + " has no slots.")); + } return third; } From rschlatte at common-lisp.net Sun Aug 26 19:23:17 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 26 Aug 2012 12:23:17 -0700 Subject: [armedbear-cvs] r14137 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Aug 26 12:23:15 2012 New Revision: 14137 Log: Update instance layout in (set-)standard-instance-access if necessary. - Reported by Pascal Costanza Modified: trunk/abcl/src/org/armedbear/lisp/StandardObject.java Modified: trunk/abcl/src/org/armedbear/lisp/StandardObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardObject.java Sun Aug 26 10:37:30 2012 (r14136) +++ trunk/abcl/src/org/armedbear/lisp/StandardObject.java Sun Aug 26 12:23:15 2012 (r14137) @@ -428,6 +428,10 @@ public LispObject execute(LispObject first, LispObject second) { final StandardObject instance = checkStandardObject(first); + if (instance.layout.isInvalid()) { + // Update instance. + instance.updateLayout(); + } final int index; if (second instanceof Fixnum) { index = ((Fixnum)second).value; @@ -473,6 +477,10 @@ LispObject third) { final StandardObject instance = checkStandardObject(first); + if (instance.layout.isInvalid()) { + // Update instance. + instance.updateLayout(); + } final int index; if (second instanceof Fixnum) { index = ((Fixnum)second).value; From ehuelsmann at common-lisp.net Sun Aug 26 21:43:55 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 26 Aug 2012 14:43:55 -0700 Subject: [armedbear-cvs] r14138 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 26 14:43:53 2012 New Revision: 14138 Log: Re #241: Fix cases (compile nil '(lambda (&rest foo &aux x))) and (compile nil '(lambda (&aux x &rest))) Note: Since the other 2 cases mentioned in the ticket are still open, this commit doesn't actually close it. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun Aug 26 12:23:15 2012 (r14137) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun Aug 26 14:43:53 2012 (r14138) @@ -92,9 +92,19 @@ keyword - the keyword argument to match against " - (let ((state :req) + (let ((remaining lambda-list) + (state :req) req opt key rest whole env aux key-p allow-others-p) - (dolist (arg lambda-list) + (when (eq (car lambda-list) '&WHOLE) + (let ((var (second lambda-list))) + (when (memq var lambda-list-keywords) + (error 'program-error + :format-control "Lambda list keyword ~A found where &WHOLE ~ + variable expected in lambda list ~A." + :format-arguments (list var lambda-list))) + (setf whole (list var)) + (setf remaining (nthcdr 2 lambda-list)))) + (dolist (arg remaining) (case arg (&optional (setf state :opt)) (&key (setf state :key @@ -105,6 +115,10 @@ allow-others-p t)) (&whole (setf state :whole)) (&environment (setf state :env)) + (&whole + (error 'program-error + :format-control "&WHOLE must appear first in lambda list ~A." + :format-arguments (list lambda-list))) (t (case state (:req (push (list arg) req)) @@ -112,8 +126,6 @@ state :none)) (:env (setf env (list arg) state :req)) - (:whole (setf whole (list arg) - state :req)) (:none (error "Invalid lambda list: argument found in :none state.")) (:opt @@ -767,17 +779,25 @@ (declare (ignore key-p allow-key-p)) (mapcan (lambda (x) (mapcar #'first x)) - (list req opt key aux rest whole env)))) + (list req opt key aux (list rest) (list whole) (list env))))) +(defun lambda-list-keyword-p (x) + (memq x lambda-list-keywords)) (defun rewrite-aux-vars (form) (let* ((lambda-list (cadr form)) (aux-p (memq '&AUX lambda-list)) - (lets (cdr aux-p)) + (post-aux-&environment (memq '&ENVIRONMENT aux-p)) + (lets (ldiff (cdr aux-p) post-aux-&environment)) ; strip trailing &environment aux-vars) (unless aux-p ;; no rewriting required (return-from rewrite-aux-vars form)) + (dolist (var lets) + (when (lambda-list-keyword-p var) + (error 'program-error + :format-control "Lambda list keyword ~A not allowed after &AUX in ~A." + :format-arguments (list var lambda-list)))) (multiple-value-bind (body decls) (parse-body (cddr form)) (dolist (form lets) @@ -785,7 +805,9 @@ (push (car form) aux-vars)) (t (push form aux-vars)))) - (setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list))) + (setf lambda-list + (append (subseq lambda-list 0 (position '&AUX lambda-list)) + post-aux-&environment)) (multiple-value-bind (let-decls lambda-decls) (split-decls decls (lambda-list-names lambda-list)) `(lambda ,lambda-list From ehuelsmann at common-lisp.net Fri Aug 31 22:07:05 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 31 Aug 2012 15:07:05 -0700 Subject: [armedbear-cvs] r14139 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 31 15:07:04 2012 New Revision: 14139 Log: Fix a slew of DMC-TEST-ARGS-WITH-WHOLE.* tests. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Aug 26 14:43:53 2012 (r14138) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Aug 31 15:07:04 2012 (r14139) @@ -1269,7 +1269,10 @@ (,needs-args-len-var) (,emf-form (let* (,@(when whole - `((,whole ',args-var))) + `((,whole (progn + (push `(,',whole ,',args-var) + ,binding-forms) + ',args-var)))) ,@(when rest ;; ### TODO: use a fresh symbol for the rest ;; binding being generated and pushed into binding-forms From ehuelsmann at common-lisp.net Fri Aug 31 22:07:49 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 31 Aug 2012 15:07:49 -0700 Subject: [armedbear-cvs] r14140 - trunk/abcl/test/lisp/abcl Message-ID: Author: ehuelsmann Date: Fri Aug 31 15:07:48 2012 New Revision: 14140 Log: Fix more DMC-TEST-ARGS-WITH-WHOLE.* tests. Modified: trunk/abcl/test/lisp/abcl/clos-tests.lisp Modified: trunk/abcl/test/lisp/abcl/clos-tests.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/clos-tests.lisp Fri Aug 31 15:07:04 2012 (r14139) +++ trunk/abcl/test/lisp/abcl/clos-tests.lisp Fri Aug 31 15:07:48 2012 (r14140) @@ -330,7 +330,7 @@ (define-method-combination dmc-test-args-with-whole.2 () ((methods ())) (:arguments &whole whole &rest rest) - `(progn (format nil "using ~a ~a" whole rest) + `(progn (format nil "using ~a ~a" ,whole ,rest) ,@(mapcar (lambda (method) `(call-method ,method)) methods))) @@ -346,7 +346,7 @@ (define-method-combination dmc-test-args-with-whole.3a () ((methods ())) (:arguments &whole whole &optional opt) - `(progn (format nil "using ~a ~a" whole opt) + `(progn (format nil "using ~a ~a" ,whole ,opt) ,@(mapcar (lambda (method) `(call-method ,method)) methods))) @@ -361,7 +361,7 @@ (define-method-combination dmc-test-args-with-whole.3b () ((methods ())) (:arguments &whole whole &optional opt &key k) - `(progn (format nil "using ~a ~a ~a" whole opt k) + `(progn (format nil "using ~a ~a ~a" ,whole ,opt ,k) ,@(mapcar (lambda (method) `(call-method ,method)) methods))) @@ -376,7 +376,7 @@ (define-method-combination dmc-test-args-with-whole.3c () ((methods ())) (:arguments &whole whole &optional opt &rest r) - `(progn (format nil "using ~a ~a ~a" whole opt r) + `(progn (format nil "using ~a ~a ~a" ,whole ,opt ,r) ,@(mapcar (lambda (method) `(call-method ,method)) methods))) @@ -392,7 +392,7 @@ (define-method-combination dmc-test-args-with-whole.3d () ((methods ())) (:arguments &whole whole &optional opt &rest r &key k) - `(progn (format nil "using ~a ~a ~a ~a" whole opt r k) + `(progn (format nil "using ~a ~a ~a ~a" ,whole ,opt ,r ,k) ,@(mapcar (lambda (method) `(call-method ,method)) methods))) @@ -407,7 +407,7 @@ (define-method-combination dmc-test-args-with-whole.4 () ((methods ())) (:arguments &whole whole &key k) - `(progn (format nil "using ~a ~a" whole k) + `(progn (format nil "using ~a ~a" ,whole ,k) ,@(mapcar (lambda (method) `(call-method ,method)) methods))) @@ -422,7 +422,7 @@ (define-method-combination dmc-test-args-with-whole.5 () ((methods ())) (:arguments &whole whole &aux a) - `(progn (format nil "using ~a ~a" whole a) + `(progn (format nil "using ~a ~a" ,whole ,a) ,@(mapcar (lambda (method) `(call-method ,method)) methods))) From ehuelsmann at common-lisp.net Fri Aug 31 23:29:07 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 31 Aug 2012 16:29:07 -0700 Subject: [armedbear-cvs] r14141 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 31 16:29:06 2012 New Revision: 14141 Log: Fix the last DMC-TEST-WITH-ARGS-* failures. Note: Now I can continue defining DMC-* tests... Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Aug 31 15:07:48 2012 (r14140) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Aug 31 16:29:06 2012 (r14141) @@ -1255,9 +1255,7 @@ (setf rest (gensym)))) (let* ((gf-lambda-list (gensym)) (args-var (gensym)) - (args-len-var (when (or (some #'second optional) - (some #'second keys)) - (gensym))) + (args-len-var (gensym)) (binding-forms (gensym)) (needs-args-len-var (gensym)) (emf-form (gensym)))