From: <cli...@li...> - 2004-06-27 03:35:54
|
Send clisp-cvs mailing list submissions to cli...@li... To subscribe or unsubscribe via the World Wide Web, visit https://lists.sourceforge.net/lists/listinfo/clisp-cvs or, via email, send a message with subject or body 'help' to cli...@li... You can reach the person managing the list at cli...@li... When replying, please edit your Subject line so it is more specific than "Re: Contents of clisp-cvs digest..." CLISP CVS commits for today Today's Topics: 1. clisp/src init.lisp,1.154,1.155 clos-package.lisp,1.13,1.14 clos-class3.lisp,1.7,1.8 clos-class6.lisp,1.2,1.3 ChangeLog,1.3259,1.3260 (Bruno Haible) 2. clisp/src clos-methcomb1.lisp,1.9,1.10 clos-methcomb2.lisp,1.21,1.22 ChangeLog,1.3260,1.3261 (Bruno Haible) 3. clisp/src ChangeLog,1.3261,1.3262 pathname.d,1.324,1.325 w32shell.c,1.2,1.3 (Arseny Slobodjuk) --__--__-- Message: 1 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src init.lisp,1.154,1.155 clos-package.lisp,1.13,1.14 clos-class3.lisp,1.7,1.8 clos-class6.lisp,1.2,1.3 ChangeLog,1.3259,1.3260 Date: Sat, 26 Jun 2004 11:39:27 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv1271/src Modified Files: init.lisp clos-package.lisp clos-class3.lisp clos-class6.lisp ChangeLog Log Message: Make the class-precedence-list computation customizable. Index: init.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/init.lisp,v retrieving revision 1.154 retrieving revision 1.155 diff -u -d -r1.154 -r1.155 --- init.lisp 25 Jun 2004 10:46:14 -0000 1.154 +++ init.lisp 26 Jun 2004 11:39:24 -0000 1.155 @@ -456,6 +456,7 @@ class-direct-subclasses class-direct-slots class-slots class-direct-default-initargs class-default-initargs class-prototype class-finalized-p finalize-inheritance + compute-class-precedence-list validate-superclass add-direct-subclass remove-direct-subclass ;; MOP for specializers specializer-direct-generic-functions specializer-direct-methods Index: clos-class3.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class3.lisp,v retrieving revision 1.7 retrieving revision 1.8 diff -u -d -r1.7 -r1.8 --- clos-class3.lisp 25 Jun 2004 10:40:48 -0000 1.7 +++ clos-class3.lisp 26 Jun 2004 11:39:24 -0000 1.8 @@ -551,7 +551,8 @@ (dolist (super added-direct-superclasses) (add-direct-subclass super class))))) -;;; CLtL2 28.1.5., ANSI CL 4.3.5. Determining the Class Precedence List +;; ---------------------------------------------------------------------------- +;; CLtL2 28.1.5., ANSI CL 4.3.5. Determining the Class Precedence List ;; The set of all classes forms a directed graph: Class C is located ;; below the direct superclasses of C. This graph is acyclic, because @@ -698,6 +699,50 @@ direct-superclasses) L)) +(defun compute-class-precedence-list-<class> (class) + (std-compute-cpl class (class-direct-superclasses class))) + +;; Preliminary. +(defun compute-class-precedence-list (class) + (compute-class-precedence-list-<class> class)) + +(defun checked-compute-class-precedence-list (class) + (let ((cpl (compute-class-precedence-list class)) + (name (class-name class))) + ; Some checks, to guarantee that user-defined methods on + ; compute-class-precedence-list don't break our CLOS. + (unless (proper-list-p cpl) + (error (TEXT "Wrong ~S result for class ~S: not a proper list: ~S") + 'compute-class-precedence-list name cpl)) + (dolist (c cpl) + (unless (class-p c) + (error (TEXT "Wrong ~S result for class ~S: list element is not a class: ~S") + 'compute-class-precedence-list name c))) + (unless (eq (first cpl) class) + (error (TEXT "Wrong ~S result for class ~S: list doesn't start with the class itself: ~S") + 'compute-class-precedence-list name cpl)) + (unless (or (eq name 't) ; for bootstrapping + (eq (car (last cpl)) <t>)) + (error (TEXT "Wrong ~S result for class ~S: list doesn't end with ~S: ~S") + 'compute-class-precedence-list name <t> cpl)) + (unless (= (length cpl) (length (remove-duplicates cpl :test #'eq))) + (error (TEXT "Wrong ~S result for class ~S: list contains duplicates: ~S") + 'compute-class-precedence-list name cpl)) + (let ((superclasses (reduce #'union + (mapcar #'class-precedence-list + (class-direct-superclasses class)) + :initial-value '()))) + (let ((forgotten (set-difference superclasses cpl))) + (when forgotten + (error (TEXT "Wrong ~S result for class ~S: list doesn't contain the superclass~[~;~:;es~] ~{~S~^, ~}.") + 'compute-class-precedence-list name (length forgotten) forgotten))) + (let ((extraneous (set-difference (rest cpl) superclasses))) + (when extraneous + (error (TEXT "Wrong ~S result for class ~S: list contains elements that are not superclasses: ~{~S~^, ~}") + 'compute-class-precedence-list name extraneous)))) + ; Now we've checked the CPL is OK. + cpl)) + ;; Stuff all superclasses (from the precedence-list) into a hash-table. (defun std-compute-superclasses (precedence-list) (let ((ht (make-hash-table :key-type 'class :value-type '(eql t) @@ -715,6 +760,7 @@ (eq superclassname 'structure-stablehash)) (return t))))) +;; ---------------------------------------------------------------------------- ;; CLtL2 28.1.3.2., ANSI CL 7.5.3. Inheritance of Slots and Slot Options (defun std-compute-slots (class) @@ -920,7 +966,7 @@ (apply #'initialize-instance-<class> class args) ; Initialize the remaining <class> slots: (setf (class-precedence-list class) - (std-compute-cpl class direct-superclasses)) + (checked-compute-class-precedence-list class)) (setf (class-all-superclasses class) (std-compute-superclasses (%class-precedence-list class))) (setf (class-slots class) '()) @@ -969,7 +1015,7 @@ (setq direct-superclasses (class-direct-superclasses class)) ; augmented ; Initialize the remaining <class> slots: (setf (class-precedence-list class) - (std-compute-cpl class direct-superclasses)) + (checked-compute-class-precedence-list class)) (setf (class-all-superclasses class) (std-compute-superclasses (%class-precedence-list class))) (unless names @@ -1147,7 +1193,7 @@ (check-metaclass-mix name direct-superclasses #'standard-class-p 'STANDARD-CLASS) (setf (class-precedence-list class) - (std-compute-cpl class direct-superclasses)) + (checked-compute-class-precedence-list class)) (setf (class-all-superclasses class) (std-compute-superclasses (%class-precedence-list class))) (dolist (super direct-superclasses) Index: clos-class6.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class6.lisp,v retrieving revision 1.2 retrieving revision 1.3 diff -u -d -r1.2 -r1.3 --- clos-class6.lisp 25 Jun 2004 10:40:48 -0000 1.2 +++ clos-class6.lisp 26 Jun 2004 11:39:24 -0000 1.3 @@ -275,6 +275,12 @@ (:method ((name symbol)) (class-finalized-p (find-class name)))) +;; MOP p. 38 +(fmakunbound 'compute-class-precedence-list) +(defgeneric compute-class-precedence-list (class) + (:method ((class class)) + (compute-class-precedence-list-<class> class))) + ;;; =========================================================================== ;;; Class definition customization Index: clos-package.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-package.lisp,v retrieving revision 1.13 retrieving revision 1.14 diff -u -d -r1.13 -r1.14 --- clos-package.lisp 25 Jun 2004 10:46:14 -0000 1.13 +++ clos-package.lisp 26 Jun 2004 11:39:24 -0000 1.14 @@ -125,6 +125,7 @@ class-direct-subclasses class-direct-slots class-slots class-direct-default-initargs class-default-initargs class-prototype class-finalized-p finalize-inheritance + compute-class-precedence-list validate-superclass add-direct-subclass remove-direct-subclass ;; MOP for specializers specializer-direct-generic-functions specializer-direct-methods Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3259 retrieving revision 1.3260 diff -u -d -r1.3259 -r1.3260 --- ChangeLog 25 Jun 2004 19:34:54 -0000 1.3259 +++ ChangeLog 26 Jun 2004 11:39:24 -0000 1.3260 @@ -1,3 +1,18 @@ +2004-05-29 Bruno Haible <br...@cl...> + + Make the class-precedence-list computation customizable. + * init.lisp: Export compute-class-precedence-list. + * clos-package.lisp: Likewise. + * clos-class3.lisp (compute-class-precedence-list-<class>, + compute-class-precedence-list, checked-compute-class-precedence-list): + New functions. + (initialize-instance-<built-in-class>, + initialize-instance-<structure-class>, + finalize-instance-standard-class): Use + checked-compute-class-precedence-list instead of std-compute-cpl. + * clos-class6.lisp (compute-class-precedence-list): New generic + function. + 2004-06-25 Sam Steingold <sd...@gn...> * lispbibl.d, spvw.d, xthread.d, zthread.d (thread_t): --__--__-- Message: 2 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src clos-methcomb1.lisp,1.9,1.10 clos-methcomb2.lisp,1.21,1.22 ChangeLog,1.3260,1.3261 Date: Sat, 26 Jun 2004 11:42:11 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv1604/src Modified Files: clos-methcomb1.lisp clos-methcomb2.lisp ChangeLog Log Message: Change the calling convention of the method-combination expander. Index: clos-methcomb1.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-methcomb1.lisp,v retrieving revision 1.9 retrieving revision 1.10 diff -u -d -r1.9 -r1.10 --- clos-methcomb1.lisp 25 Jun 2004 10:46:14 -0000 1.9 +++ clos-methcomb1.lisp 26 Jun 2004 11:42:08 -0000 1.10 @@ -43,8 +43,12 @@ ; that checks the syntax of arguments to the ; method combination (expander nil) ; A function of 4 arguments - ; (function method-combination methods options) - ; which computes a combined method function. + ; (function method-combination options methods) + ; which computes two values: 1. the inner body + ; of the effective method, as a form containing + ; (CALL-METHOD ...) forms, 2. a list of + ; options describing the wrapper, such as + ; (:ARGUMENTS ...) or (:GENERIC-FUNCTION ...). (check-method-qualifiers nil) ; A function of 3 arguments ; (function method-combination method) ; that checks whether the method's qualifiers Index: clos-methcomb2.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-methcomb2.lisp,v retrieving revision 1.21 retrieving revision 1.22 diff -u -d -r1.21 -r1.22 --- clos-methcomb2.lisp 25 Jun 2004 10:48:29 -0000 1.21 +++ clos-methcomb2.lisp 26 Jun 2004 11:42:08 -0000 1.22 @@ -251,17 +251,17 @@ (ADD-NEXT-METHOD-LOCAL-FUNCTIONS 'NIL CONT ',req-vars ',rest-var (CDR METHOD)))))))))))) -(defun compute-effective-method-function (generic-function combination methods - effective-method-form) - "Given the generic function, its combination, and the effective method form, -constructs and compiles the lambda form for the correct arguments -and with the next-method support." +(defun build-effective-method-function-form (generic-function combination methods + effective-method-form + combination-arguments-lambda-list) + "Given the generic function, its combination, and the effective method form +and the arguments-lambda-list specifying variables for it, constructs the +function form for the effective method, including correct arguments and with +the next-method support." (multiple-value-bind (lambdalist lambdalist-keypart firstforms apply-fun apply-args macrodefs) (effective-method-code-bricks generic-function methods) (declare (ignore lambdalist-keypart)) (let* ((declarations (method-combination-declarations combination)) - (combination-arguments-lambda-list - (method-combination-arguments-lambda-list combination)) (ef-fun (if (and (consp effective-method-form) (eq (first effective-method-form) 'CALL-METHOD) @@ -393,8 +393,13 @@ (defun compute-effective-method-as-function-form (gf combination methods) ;; Apply method combination: - (funcall (method-combination-expander combination) - gf combination methods (method-combination-options combination))) + (multiple-value-bind (effective-method-form effective-method-options) + (funcall (method-combination-expander combination) + gf combination (method-combination-options combination) methods) + ;; Build a function form around the inner form: + (build-effective-method-function-form gf combination methods + effective-method-form + (cdr (assoc ':ARGUMENTS effective-method-options))))) ;;; ----------------------- Standard Method Combination ----------------------- @@ -423,62 +428,52 @@ (nreverse after-methods) (nreverse around-methods)))) -(defun standard-method-combination-expander (gf combination methods options) +(defun standard-method-combination-expander (gf combination options methods) (declare (ignore combination)) (declare (ignore options)) ; already checked in check-options - (multiple-value-bind (lambdalist lambdalist-keypart firstforms apply-fun apply-args macrodefs) - (effective-method-code-bricks gf methods) - (declare (ignore lambdalist-keypart apply-fun apply-args)) - ;; Split up into individual method types. - (multiple-value-bind - (primary-methods before-methods after-methods around-methods) - (partition-method-list methods) - (when (null primary-methods) - (return-from standard-method-combination-expander - (no-method-caller 'no-primary-method gf))) - ;; Combine methods into an "effective method": - (labels ((ef-1 (primary-methods before-methods after-methods - around-methods) - (if (null around-methods) - (ef-2 primary-methods before-methods after-methods) - (let ((next-ef - (ef-1 primary-methods before-methods - after-methods (rest around-methods)))) - `(CALL-METHOD ,(first around-methods) - ,(list `(MAKE-METHOD ,next-ef)))))) - (forms-for-invoking-sequentially (methods) - (mapcar #'(lambda (method) - `(CALL-METHOD ,method)) - methods)) - (ef-2 (primary-methods before-methods after-methods) - (let ((next-ef (ef-3 primary-methods after-methods))) - (if (null before-methods) - next-ef - `(PROGN - ; most-specific-first: - ,@(forms-for-invoking-sequentially before-methods) - ,next-ef)))) - (ef-3 (primary-methods after-methods) - (let ((next-ef (ef-4 primary-methods))) - (if (null after-methods) - next-ef - `(MULTIPLE-VALUE-PROG1 - ,next-ef - ; most-specific-last: - ,@(forms-for-invoking-sequentially (reverse after-methods)))))) - (ef-4 (primary-methods) - `(CALL-METHOD ,(first primary-methods) ,(rest primary-methods)))) - (let* ((ef-form (ef-1 primary-methods before-methods after-methods - around-methods)) - (ef-fun (if (and (eq (first ef-form) 'CALL-METHOD) - (typep (second ef-form) <method>) - (not (std-method-wants-next-method-p (second ef-form)))) - (std-method-function (second ef-form)) - `#'(LAMBDA ,lambdalist - ,@firstforms - (MACROLET ,macrodefs - ,ef-form))))) - ef-fun))))) + ;; Split up into individual method types. + (multiple-value-bind (primary-methods before-methods after-methods around-methods) + (partition-method-list methods) + (when (null primary-methods) + (return-from standard-method-combination-expander + (let ((rest-variable (gensym))) + (values `(APPLY #'NO-PRIMARY-METHOD ',gf ,rest-variable) + `((:ARGUMENTS &WHOLE ,rest-variable)))))) + ;; Combine methods into an "effective method": + (labels ((ef-1 (primary-methods before-methods after-methods + around-methods) + (if (null around-methods) + (ef-2 primary-methods before-methods after-methods) + (let ((next-ef + (ef-1 primary-methods before-methods + after-methods (rest around-methods)))) + `(CALL-METHOD ,(first around-methods) + ,(list `(MAKE-METHOD ,next-ef)))))) + (forms-for-invoking-sequentially (methods) + (mapcar #'(lambda (method) + `(CALL-METHOD ,method)) + methods)) + (ef-2 (primary-methods before-methods after-methods) + (let ((next-ef (ef-3 primary-methods after-methods))) + (if (null before-methods) + next-ef + `(PROGN + ; most-specific-first: + ,@(forms-for-invoking-sequentially before-methods) + ,next-ef)))) + (ef-3 (primary-methods after-methods) + (let ((next-ef (ef-4 primary-methods))) + (if (null after-methods) + next-ef + `(MULTIPLE-VALUE-PROG1 + ,next-ef + ; most-specific-last: + ,@(forms-for-invoking-sequentially (reverse after-methods)))))) + (ef-4 (primary-methods) + `(CALL-METHOD ,(first primary-methods) ,(rest primary-methods)))) + (values + (ef-1 primary-methods before-methods after-methods around-methods) + '())))) (defun standard-method-combination-check-method-qualifiers (gf method-combo method) ;; CLtL2 28.1.7.2., 28.1.7.4., ANSI CL 7.6.6.2., 7.6.6.4. Method qualifiers @@ -523,19 +518,25 @@ (unless (memq order '(:most-specific-first :most-specific-last)) (invalid-sort-order-error 'order order)))))) -(defun compute-short-form-effective-method-form (combination options methods) - (flet ((partition-short-form-method-list (combination methods order) +(defun compute-short-form-effective-method-form (gf combination options methods) + (destructuring-bind (&optional (order ':most-specific-first)) options + (let ((operator (method-combination-operator combination))) + (multiple-value-bind (primary around) (let ((primary-methods '()) (around-methods '()) (qualifier (method-combination-name combination))) (dolist (method methods) (let ((quals (std-method-qualifiers method))) (if (equal quals '(:around)) - (push method around-methods) - (push method primary-methods)))) - (unless primary-methods - (method-combination-error (TEXT "no applicable primary methods."))) + (push method around-methods) + (push method primary-methods)))) + (when (null primary-methods) + (return-from compute-short-form-effective-method-form + (let ((rest-variable (gensym))) + (values `(APPLY #'NO-PRIMARY-METHOD ',gf ,rest-variable) + `((:ARGUMENTS &WHOLE ,rest-variable)))))) ;; check that all qualifiers are singular and correct + ;; FIXME: move this check to check-method-qualifiers (dolist (method primary-methods) (let ((qualifiers (std-method-qualifiers method))) (unless (and (null (rest qualifiers)) @@ -544,35 +545,24 @@ method (TEXT "qualifiers ~s not permitted for combination ~s.") qualifiers qualifier)))) (values - (ecase order - (:most-specific-first (nreverse primary-methods)) - (:most-specific-last primary-methods)) - (nreverse around-methods))))) - (destructuring-bind (&optional (order ':most-specific-first)) options - (let ((operator (method-combination-operator combination))) - (multiple-value-bind (primary around) - (partition-short-form-method-list combination methods order) - (flet ((call-methods (methods) - (mapcar #'(lambda (method) `(call-method ,method)) - methods))) - (let ((form - (if (or (rest primary) - (not (method-combination-identity-with-one-argument - combination))) - `(,operator ,@(call-methods primary)) - `(call-method ,(first primary))))) - (when around - (setq form - `(call-method ,(first around) - (,@(rest around) (make-method ,form))))) - form))))))) + (ecase order + (:most-specific-first (nreverse primary-methods)) + (:most-specific-last primary-methods)) + (nreverse around-methods))) + (let ((form + (if (and (null (rest primary)) + (method-combination-identity-with-one-argument combination)) + `(CALL-METHOD ,(first primary)) + `(,operator ,@(mapcar #'(lambda (method) `(CALL-METHOD ,method)) primary))))) + (when around + (setq form `(CALL-METHOD ,(first around) + (,@(rest around) (make-method ,form))))) + (values form '())))))) (defun short-form-method-combination-expander - (*method-combination-generic-function* *method-combination* methods options) - (compute-effective-method-function - *method-combination-generic-function* *method-combination* methods - (compute-short-form-effective-method-form - *method-combination* options methods))) + (*method-combination-generic-function* *method-combination* options methods) + (compute-short-form-effective-method-form + *method-combination-generic-function* *method-combination* options methods)) (defun short-form-method-combination-check-method-qualifiers (gf method-combo method) (standard-method-combination-check-method-qualifiers gf method-combo method) @@ -606,9 +596,9 @@ (defun long-form-method-combination-expander (*method-combination-generic-function* *method-combination* methods options long-expander) - (compute-effective-method-function - *method-combination-generic-function* *method-combination* methods - (apply long-expander *method-combination-generic-function* methods options))) + (values + (apply long-expander *method-combination-generic-function* methods options) + `((:ARGUMENTS ,@(method-combination-arguments-lambda-list *method-combination*))))) (defun long-form-method-combination-call-next-method-allowed (gf method-combo method) (declare (ignore gf method-combo method)) @@ -993,7 +983,7 @@ (,check-options-lambda))))) :EXPANDER #'(LAMBDA (,gf-variable ,combination-variable - ,methods-variable ,options-variable) + ,options-variable ,methods-variable) (LONG-FORM-METHOD-COMBINATION-EXPANDER ,gf-variable ,combination-variable ,methods-variable ,options-variable Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3260 retrieving revision 1.3261 diff -u -d -r1.3260 -r1.3261 --- ChangeLog 26 Jun 2004 11:39:24 -0000 1.3260 +++ ChangeLog 26 Jun 2004 11:42:08 -0000 1.3261 @@ -1,3 +1,20 @@ +2004-06-09 Bruno Haible <br...@cl...> + + * clos-methcomb1.lisp (method-combination): Change calling convention + of expander. + * clos-methcomb2.lisp (build-effective-method-function-form): Renamed + from compute-effective-method-function. Take arguments-lambda-list as + additional argument. + (compute-effective-method-as-function-form): After calling the + expander, call build-effective-method-function-form. + (standard-method-combination-expander): Return two values now, instead + of the entire function-form. + (compute-short-form-effective-method-form): Likewise. Simplify. + (short-form-method-combination-expander): Don't call + compute-effective-method-function on the result. + (long-form-method-combination-expander): Likewise. + (define-method-combination): Update. + 2004-05-29 Bruno Haible <br...@cl...> Make the class-precedence-list computation customizable. --__--__-- Message: 3 From: Arseny Slobodjuk <am...@us...> To: cli...@li... Subject: clisp/src ChangeLog,1.3261,1.3262 pathname.d,1.324,1.325 w32shell.c,1.2,1.3 Date: Sat, 26 Jun 2004 15:07:40 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2238 Modified Files: ChangeLog pathname.d w32shell.c Log Message: Fixed relative shortcuts at mingw. Index: pathname.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/pathname.d,v retrieving revision 1.324 retrieving revision 1.325 diff -u -d -r1.324 -r1.325 --- pathname.d 24 Jun 2004 16:58:04 -0000 1.324 +++ pathname.d 26 Jun 2004 15:07:33 -0000 1.325 @@ -5151,41 +5151,134 @@ /* UP: translates short name to full name > shortname: old DOS 8.3 pathname + wildcards aren't allowed. "." and ".." can be used. < fullname: buffer should be not less than MAX_PATH < result: true on success */ -bool FullName (LPCSTR shortname, LPSTR fullname) { - var WIN32_FIND_DATA wfd; - var char drive[_MAX_DRIVE]; - var char dir[_MAX_DIR]; - var char fname[_MAX_FNAME]; - var char ext[_MAX_EXT]; +BOOL FullName (LPCSTR shortname, LPSTR fullname) { var char current[_MAX_PATH]; - var HANDLE h = NULL; - var *fullname = 0; /* also first loop flag */ - var char savedslash[2];savedslash[0] = 0;savedslash[1] = 0; + var char * rent = current;/* current+end-device-pos, rest after X: */ + var int state = 1; + /* states for automata reading 'rent' pathname backward: + 0 - end + 1 - beginning + 2 - name component + 3 - slash component + 9,11,13... slash component after dots (".."). + components to be skipped = (state - 9)/2 + 10,12,14... name components after dots. + components to be skipped = (state - 10)/2; */ + var enum {fn_eof, fn_name, fn_dots, fn_dot, fn_slash} symbol; + /* symbol at the end of 'rent': + 1 - generic name + 2 - ".." + 3 - "." + 4 - slash + 0 - EOF i.e. beginning of 'rent' */ + var int pos; + var int ops = 0;/* output position */ strcpy(current,shortname); + /* determine the end of device part */ + if (((current[0] >= 'a' && current[0] <= 'z') + || (current[0] >= 'A' && current[0] <= 'Z')) + && current[1] == ':') { + rent = current+2; + } else if (current[0]=='\\' && current[1]=='\\') { + int i;rent = current; + /* host */ + rent+=2; + for (i=0;i<2;i++) {/* skip host and sharename */ + while (*rent && !cpslashp(*rent)) + rent++; + if (*rent) rent++; else + return FALSE;/*host and sharename don't end with slash*/ + } + } + pos = strlen(rent); do { - var int l = strlen(current); - if (l>0 && cpslashp(current[l-1])) { - if (!*fullname) *savedslash = current[l-1]; - current[l-1] = 0; /* remove trailing slash */ + rent[pos] = '\0'; + if (pos == 0) symbol = fn_eof; else + if (cpslashp(rent[pos-1])) { pos--; symbol = fn_slash; } else + { int dotcount = 0;/* < 0 -> not only dots */ + int wild = 0; + while(pos > 0 && !cpslashp(rent[pos-1])) { + if (rent[pos-1] == '.') dotcount++; else dotcount = -pos; + if (rent[pos-1] == '*' || rent[pos-1] == '?') wild = 1; + pos--; + } + if (wild) return FALSE; + if (dotcount <= 0) symbol = fn_name; else + if (dotcount == 1) symbol = fn_dot; else + if (dotcount == 2) symbol = fn_dots; else + return FALSE; /* too many dots */ } - _splitpath(current,drive,dir,fname,ext); - h = FindFirstFile(current,&wfd); - if (h != INVALID_HANDLE_VALUE) { - if (*fullname) strcat(fullname,"\\"); - strrev(wfd.cFileName); - strcat(fullname,wfd.cFileName); - FindClose(h); - } else return false; - _makepath(current,drive,dir,NULL,NULL); - } while (strcmp(dir,"\\")!=0); - strrev(drive); - strcat(fullname,"\\"); - strcat(fullname,drive); + if (state == 1 /* beginning */ + || state == 2 /* name component */) { + switch(symbol) { + case fn_dot: state = 3; break; /* slash */ + case fn_dots: state = 11; break; /* dots-slash */ + case fn_name: { + var WIN32_FIND_DATA wfd; + var HANDLE h = NULL; + h = FindFirstFile(current,&wfd); + if (h != INVALID_HANDLE_VALUE) { + strrev(wfd.cFileName); + if (ops > 0 || wfd.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) + fullname[ops++] = '\\'; + strcpy(fullname+ops,wfd.cFileName); + ops+=strlen(wfd.cFileName); + FindClose(h); + } else return FALSE; /* file not found */ + state = 3; + } break; + case fn_slash: + if (state == 1) state = 2; + else return FALSE; /* two slashes in a row */ + break; + case fn_eof: + if (state == 1 && current == rent) return FALSE; /* D: */ + else state = 0; + break; + default: + return FALSE;/* program error */ + } + } else if (state == 3) {/* slash */ + switch(symbol) { + case fn_slash: state = 2;break; + case fn_eof: + if (current == rent) state = 0; else return FALSE; /*D:FOO*/ + break; + default: return FALSE; /* program error */ + } + } else if (state % 2 == 1) {/* dots - slash 9, 11, 13 ... */ + switch(symbol) { + case fn_slash: + state += 1; + if (state == 10) state = 2; /* zero depth */ + break; /* same depth */ + case fn_eof: + return FALSE; /* too many ".." */ + break; + default: return FALSE; /* program error */ + } + } else {/* dots - name 10, 12, 14, ... */ + switch(symbol) { + case fn_dot: state -= 1; break; /* same depth */ + case fn_dots: state += 1; break; /* increase depth */ + case fn_name: state -= 3; /* decrease depth */ + if (state < 9) return FALSE; /* program error */ + break; + case fn_slash: return FALSE; /* two slashes */ + case fn_eof: return FALSE; /* too many ".."s */ + } + } + } while (state != 0); + if (rent > current) fullname[ops++] = '\\'; + /* add device */ + while(rent > current) + fullname[ops++] = (rent--)[-1]; + fullname[ops] = '\0'; strrev(fullname); - if (*savedslash) strcat(fullname,savedslash); - return true; + return TRUE; } #endif @@ -7009,7 +7102,7 @@ || (dsp->if_none != DIR_IF_NONE_DISCARD && dsp->if_none != DIR_IF_NONE_IGNORE)) { if (READDIR_entry_ISDIR() || rresolved == shell_shortcut_directory) { - /* nonfound shortcuts are threated as shortcuts to files */ + /* nonfound shortcuts are treated as shortcuts to files */ if (recursively) { /* all recursive subdirectories wanted? */ /* yes -> push truename onto pathnames-to-insert (is inserted in front of Index: w32shell.c =================================================================== RCS file: /cvsroot/clisp/clisp/src/w32shell.c,v retrieving revision 1.2 retrieving revision 1.3 diff -u -d -r1.2 -r1.3 --- w32shell.c 19 Oct 2003 20:52:49 -0000 1.2 +++ w32shell.c 26 Jun 2004 15:07:37 -0000 1.3 @@ -79,6 +79,37 @@ return result; } +#if !defined(cpslashp) +# define cpslashp(c) ((c) == '\\' || (c) == '/') +#endif + +/* Uses the base from filename to augment pathname. + Return false when (pathname is relative AND filename doesn't + contain the base), so pathname (contained in shortcut) + cannot be referenced other than to current directory + what is wrong. */ +static BOOL augment_relative_pathname(LPCSTR filename, LPSTR pathname) { + /* check if pathname is absolute */ + /* what to do with "/bar/foo" pathnames ?*/ + if (cpslashp(pathname[0])) return FALSE; /* let's panic */ + if (((pathname[0] >= 'a' && pathname[0] <= 'z') + || (pathname[0] >= 'A' && pathname[0] <= 'Z')) + && pathname[1] == ':' && cpslashp(pathname[2])) return TRUE; + if (pathname[0] == '\\' && pathname[1] == '\\') return TRUE; + { + int fl = strlen(filename); + int pl = strlen(pathname); + const char * cp = filename + fl - 1; + /* find the last slash */ + for (;!cpslashp(*cp) && cp > filename;cp--); + if (!cpslashp(*cp)) return FALSE; /* no slash */ + memmove(pathname + (cp - filename + 1),pathname,pl + 1); + memmove(pathname,filename,cp - filename + 1); + } + return TRUE; +} + + typedef enum { shell_shortcut_notresolved = 0, shell_shortcut_notexists, @@ -94,16 +125,28 @@ resolve_shell_shortcut_more (LPCSTR filename, LPSTR resolved) { char pathname[_MAX_PATH]; + char pathname1[_MAX_PATH]; int dirp = 0; int exists = 0; int try_counter = 33; - int l, resolvedp = resolve_shell_shortcut(filename,pathname); + int l, resolvedp = resolve_shell_shortcut(filename,pathname) + && augment_relative_pathname(filename,pathname); /* handle links to links. cygwin can do such */ - while (resolvedp - && try_counter-- - && (l=strlen(pathname))>4 - && stricmp(pathname+l-4,".lnk") == 0 - && (resolvedp = resolve_shell_shortcut(pathname,pathname))); + while (resolvedp && try_counter--) { + l=strlen(pathname); + if (l >= 4 && stricmp(pathname+l-4,".lnk") == 0) + resolvedp = resolve_shell_shortcut(pathname,pathname1) + && augment_relative_pathname(pathname,pathname1) + && strcpy(pathname,pathname1); + else { + /* not a link to shortcut but can be the symbolic filename */ + strcpy(pathname+l,".lnk"); + if (!resolve_shell_shortcut(pathname,pathname1) + || !augment_relative_pathname(pathname,pathname1)) { + pathname[l] = '\0'; break; } + else strcpy(pathname,pathname1); + } + } if (resolvedp) { /* additional checks */ DWORD fileattr = GetFileAttributes(pathname); exists = fileattr != 0xFFFFFFFF; @@ -141,10 +184,6 @@ return resolve_shell_shortcut_more(pathname,resolved); } -#if !defined(cpslashp) -# define cpslashp(c) ((c) == '\\' || (c) == '/') -#endif - /* the ultimate shortcut megaresolver style inspired by directory_search_scandir > namein: filename pointing to file or directory @@ -163,7 +202,6 @@ char saved_char; BOOL next_name = 0;/* if we found an lnk and need to start over */ int try_counter = 33; - strcpy(nameout,namein); do { /* whole file names */ next_name = FALSE; @@ -175,7 +213,7 @@ && nametocheck[1] == ':' && cpslashp(nametocheck[2])) /* drive */ nametocheck += 3; - else if (cpslashp(*nametocheck)) { + else if (nametocheck[0]=='\\' && nametocheck[1]=='\\') { int i; /* host */ nametocheck+=2; Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3261 retrieving revision 1.3262 diff -u -d -r1.3261 -r1.3262 --- ChangeLog 26 Jun 2004 11:42:08 -0000 1.3261 +++ ChangeLog 26 Jun 2004 15:07:32 -0000 1.3262 @@ -1,3 +1,12 @@ +2004-06-26 Arseny Slobodjuk <am...@ic...> + + Fixed handling of relative shortcuts on mingw. + * w32shell.c (augment_relative_pathname): new function. + (resolve_shell_shortcut_more): recurrent resolution of + shortcuts to symbolic names. Handling of relative shortcuts. + (real_path): fixed sharename handling (not tested). + * pathname.d (FullName): rewritten to process ".." and ".". + 2004-06-09 Bruno Haible <br...@cl...> * clos-methcomb1.lisp (method-combination): Change calling convention --__--__-- _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest |