Changeset 10086


Ignore:
Timestamp:
10/08/05 03:36:46 (16 years ago)
Author:
piso
Message:

Windows.

Location:
trunk/j/src/org/armedbear/lisp
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/Pathname.java

    r10076 r10086  
    33 *
    44 * Copyright (C) 2003-2005 Peter Graves
    5  * $Id: Pathname.java,v 1.100 2005-10-04 16:16:37 piso Exp $
     5 * $Id: Pathname.java,v 1.101 2005-10-08 03:36:46 piso Exp $
    66 *
    77 * This program is free software; you can redistribute it and/or
     
    8585        if (s == null)
    8686            return;
    87         if (s.equals(".") || s.equals("./")) {
     87        if (s.equals(".") || s.equals("./") ||
     88            (Utilities.isPlatformWindows && s.equals(".\\"))) {
    8889            directory = new Cons(Keyword.RELATIVE);
    8990            return;
     
    449450                for (int i = 0; i < limit; i++) {
    450451                    char c = s.charAt(i);
    451                     if (c == '\"' || c == '\\')
    452                         sb.append('\\');
     452                    if (printReadably || printEscape) {
     453                        if (c == '\"' || c == '\\')
     454                            sb.append('\\');
     455                    }
    453456                    sb.append(c);
    454457                }
  • trunk/j/src/org/armedbear/lisp/tests/pathname-tests.lisp

    r10074 r10086  
    22;;;
    33;;; Copyright (C) 2005 Peter Graves
    4 ;;; $Id: pathname-tests.lisp,v 1.41 2005-10-03 13:53:16 piso Exp $
     4;;; $Id: pathname-tests.lisp,v 1.42 2005-10-08 03:36:03 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    2424;;         '(("*.*.*" "/home/peter/gcl/ansi-tests/*.*")))
    2525
     26#+(and allegro mswindows)
     27(pushnew :windows *features*)
     28#+(and clisp win32)
     29(pushnew :windows *features*)
     30#+(and lispworks win32)
     31(pushnew :windows *features*)
     32
    2633(unless (member "RT" *modules* :test #'string=)
    2734  (unless (ignore-errors (logical-pathname-translations "ansi-tests"))
    2835    (error "~S is not defined as a logical pathname host." "ansi-tests"))
    29   (load "ansi-tests:rt-package.lsp")
     36  (load (translate-logical-pathname "ansi-tests:rt-package.lsp"))
    3037  (load #+abcl (compile-file-if-needed "ansi-tests:rt.lsp")
    3138        ;; Force compilation to avoid fasl name conflict between SBCL and
    3239        ;; Allegro.
    33         #-abcl (compile-file "ansi-tests:rt.lsp"))
     40        #-abcl (compile-file (translate-logical-pathname "ansi-tests:rt.lsp")))
    3441  (provide "RT"))
    3542
     
    6168      (setf ok nil))
    6269    (unless (and (equal directory expected-directory)
    63                  (equal name      expected-name)
    64                  (equal type      expected-type))
     70                 (equal name expected-name)
     71                 (equal type expected-type))
     72      (setf ok nil))
     73    ok))
     74
     75(defun check-windows-pathname (pathname expected-host expected-device
     76                                        expected-directory expected-name
     77                                        expected-type)
     78  (let* ((host (pathname-host pathname))
     79         (device (pathname-device pathname))
     80         (directory (pathname-directory pathname))
     81         (name (pathname-name pathname))
     82         (type (pathname-type pathname))
     83         (ok t))
     84    (unless (and (pathnamep pathname)
     85                 (not (typep pathname 'logical-pathname)))
     86      (setf ok nil))
     87    (unless (and (equal host expected-host)
     88                 (equal device expected-device)
     89                 (equal directory expected-directory)
     90                 (equal name expected-name)
     91                 (equal type expected-type))
    6592      (setf ok nil))
    6693    ok))
     
    252279  (check-readable-or-signals-error (make-pathname :name "."))
    253280  t)
    254 #+lispworks
     281#+(or lispworks (and allegro windows))
    255282(pushnew 'physical.21 *expected-failures*)
    256283
     
    275302;; Trailing separator character means it's a directory.
    276303(deftest physical.24
    277   #+(or allegro abcl clisp cmu)
    278   (check-physical-pathname #p"./" '(:relative) nil nil)
    279   #+(or sbcl)
    280   ;; Is this more exact?
    281   (check-physical-pathname #p"./" '(:relative ".") nil nil)
    282   t)
    283 #+(or cmu lispworks)
     304  (let ((pathname #-windows #p"./"
     305                  #+windows #p".\\"))
     306    #+(or allegro abcl clisp cmu)
     307    (check-physical-pathname pathname '(:relative) nil nil)
     308    #+(or sbcl)
     309    ;; Is this more exact?
     310    (check-physical-pathname pathname '(:relative ".") nil nil))
     311  t)
     312#+(or cmu lispworks (and allegro windows))
    284313(pushnew 'physical.24 *expected-failures*)
    285314
    286315(deftest physical.25
    287   (equal #p"./" #p"")
     316  (equal #-windows #p"./"
     317         #+windows #p".\\"
     318         #p"")
    288319  nil)
    289 #+lispworks
     320#+(or lispworks (and allegro windows))
    290321(pushnew 'physical.25 *expected-failures*)
    291 
    292322
    293323(deftest physical.26
     
    310340;; #p".."
    311341(deftest physical.28
    312   #+(or allegro)
     342  #+(or allegro (and lispworks windows))
    313343  (check-physical-pathname #p".." '(:relative :back) nil nil)
    314   #+(or abcl cmu lispworks)
     344  #+(or abcl cmu (and lispworks unix))
    315345  (check-physical-pathname #p".." '(:relative :up) nil nil)
    316346  ;; Other implementations think it's a file.
     
    329359;; #p"../"
    330360(deftest physical.29
    331   #+allegro
    332   (check-physical-pathname #p"../" '(:relative :back) nil nil)
    333   #+(or abcl sbcl cmu clisp lispworks)
    334   (check-physical-pathname #p"../" '(:relative :up) nil nil)
     361  (let ((pathname #-windows #p"../"
     362                  #+windows #p"..\\"))
     363    #+(or allegro (and lispworks windows))
     364    (check-physical-pathname pathname '(:relative :back) nil nil)
     365    #+(or abcl sbcl cmu clisp (and lispworks unix))
     366    (check-physical-pathname pathname '(:relative :up) nil nil))
    335367  t)
    336368
     
    340372  (string= (namestring (make-pathname :name "..")) "..")
    341373  #+allegro
    342   (string= (namestring (make-pathname :name "..")) "../")
     374  (string= (namestring (make-pathname :name ".."))
     375           #-windows "../"
     376           #+windows "..\\")
    343377  #+cmu (signals-error (namestring (make-pathname :name "..")) 'error)
    344378  t)
     
    348382           #+windows "..\\"
    349383           #-windows "../")
     384  t)
     385
     386#+windows
     387(deftest windows.1
     388  (let ((pathname #p"c:\\foo.bar"))
     389    #+(or abcl allegro)
     390    (check-windows-pathname #p"c:\\foo.bar" nil "c" '(:absolute) "foo" "bar")
     391    #+clisp
     392    (check-windows-pathname #p"c:\\foo.bar" nil "C" '(:absolute) "foo" "bar")
     393    #+lispworks
     394    (check-windows-pathname #p"c:\\foo.bar" "c" nil '(:absolute) "foo" "bar"))
    350395  t)
    351396
     
    435480
    436481;; If the prefix isn't a defined logical host, it's not a logical pathname.
    437 #-cmu
     482#-(or cmu (and clisp windows))
    438483;; CMUCL parses this as (:ABSOLUTE #<SEARCH-LIST foo>) "bar.baz" "42".
     484;; CLISP signals a parse error reading #p"foo:bar.baz.42".
    439485(deftest logical.1
    440   #+allegro
    441   ;; Except in Allegro.
    442   (check-logical-pathname #p"foo:bar.baz.42" "foo" nil "bar" "baz" nil)
    443   #-allegro
    444   (check-physical-pathname #p"foo:bar.baz.42" nil "foo:bar.baz" "42")
     486  (let ((pathname #p"foo:bar.baz.42"))
     487    #+allegro
     488    ;; Except in Allegro.
     489    (check-logical-pathname pathname "foo" nil "bar" "baz" nil)
     490    #-allegro
     491    (check-physical-pathname pathname nil "foo:bar.baz" "42"))
    445492  t)
    446493#+lispworks
     
    605652
    606653(deftest parse-namestring.2
    607   #-allegro
    608   (check-logical-pathname (parse-namestring "foo.bar" "effluvia")
    609                           "EFFLUVIA" '(:absolute) "FOO" "BAR" nil)
    610   #+allegro
    611   (check-logical-pathname (parse-namestring "foo.bar" "effluvia")
    612                           "effluvia" nil "foo" "bar" nil)
     654  (let ((pathname (parse-namestring "foo.bar" "effluvia")))
     655    #-(or allegro lispworks)
     656    (check-logical-pathname pathname "EFFLUVIA" '(:absolute) "FOO" "BAR" nil)
     657    #+allegro
     658    (check-logical-pathname pathname "effluvia" nil "foo" "bar" nil)
     659    #+lispworks
     660    (check-logical-pathname pathname "effluvia" '(:absolute) "FOO" "BAR" nil))
    613661  t)
    614662
    615663(deftest parse-namestring.3
    616   #-allegro
    617   (check-logical-pathname (parse-namestring "foo;bar;baz.fas.3" "effluvia")
    618                           "EFFLUVIA" '(:absolute "FOO" "BAR") "BAZ" "FAS" 3)
    619   #+allegro
    620   (check-logical-pathname (parse-namestring "foo;bar;baz.fas.3" "effluvia")
    621                           "effluvia" '(:absolute "foo" "bar") "baz" "fas" nil)
     664  (let ((pathname (parse-namestring "foo;bar;baz.fas.3" "effluvia")))
     665    #-(or allegro lispworks)
     666    (check-logical-pathname pathname "EFFLUVIA" '(:absolute "FOO" "BAR") "BAZ" "FAS" 3)
     667    #+allegro
     668    (check-logical-pathname pathname "effluvia" '(:absolute "foo" "bar") "baz" "fas" nil)
     669    #+lispworks
     670    (check-logical-pathname pathname "effluvia" '(:absolute "FOO" "BAR") "BAZ" "FAS" 3)
     671    )
    622672  t)
    623673
    624674(deftest parse-namestring.4
    625   #-(or abcl clisp cmu)
     675  #-(or abcl clisp cmu lispworks (and allegro windows))
    626676  (check-physical-pathname (parse-namestring "effluvia:foo.bar" "")
    627677                           nil "effluvia:foo" "bar")
     
    629679  ;; Invalid logical host name: ""
    630680  (signals-error (parse-namestring "effluvia:foo.bar" "") 'error)
    631   #+clisp
     681  #+(or clisp lispworks)
    632682  ;; Host mismatch.
    633683  (signals-error (parse-namestring "effluvia:foo.bar" "") 'error)
    634684  #+cmu
    635685  (signals-error (parse-namestring "effluvia:foo.bar" "") 'error)
     686  #+(and allegro windows)
     687  ;; "effluvia" is the device
     688  (check-physical-pathname (parse-namestring "effluvia:foo.bar" "")
     689                           nil "foo" "bar")
    636690  t)
    637691
     
    929983         (make-pathname :host "EFFLUVIA" :directory '(:absolute)
    930984                        :name "FOO" :type "fas" :version :newest)
    931          #+lispworks #p"EFFLUVIA:FOO.USFL.NEWEST"
    932          )
     985         #+(and lispworks unix) #p"EFFLUVIA:FOO.USFL.NEWEST"
     986         #+(and lispworks windows) #p"EFFLUVIA:FOO.FSL.NEWEST")
    933987  t)
    934988
     
    940994
    941995(deftest enough-namestring.2
     996  #-windows
    942997  (equal (enough-namestring #p"foo/bar" #p"foo") "foo/bar")
     998  #+windows
     999  (equal (enough-namestring #p"foo\\bar" #p"foo") "foo\\bar")
    9431000  t)
    9441001
     
    9691026         #+windows "\\tmp\\**\\foo.lisp")
    9701027  nil)
     1028
    9711029(deftest sbcl.4
    9721030  (check-namestring (translate-logical-pathname "demo1:foo.lisp") "/tmp/foo.lisp")
    9731031  t)
     1032
    9741033;;; Check for absolute/relative path confusion.
    9751034#-allegro
     
    9771036  (pathname-match-p "demo1:;foo.lisp" "demo1:**;*.*.*")
    9781037  nil)
     1038
    9791039#+(or sbcl cmu)
    9801040;; BUG Pathnames should match if the following translation is to work.
     
    9821042  (pathname-match-p "demo1:;foo.lisp" "demo1:;**;*.*.*")
    9831043  t)
     1044
    9841045#+clisp
    9851046(deftest sbcl.7
    9861047  (pathname-match-p "demo1:;foo.lisp" ";**;*.*.*")
    9871048  t)
     1049
    9881050(deftest sbcl.8
    989   (equal (namestring (translate-logical-pathname "demo1:;foo.lisp"))
    990          #+(and abcl windows) "\\tmp\\rel\\foo.lisp"
    991          #+(and abcl unix) "/tmp/rel/foo.lisp"
    992          #-(or allegro abcl) "/tmp/rel/foo.lisp"
    993          #+allegro "/tmp/foo.lisp")
     1051  (check-namestring (translate-logical-pathname "demo1:;foo.lisp")
     1052;;                     #+(and abcl windows) "\\tmp\\rel\\foo.lisp"
     1053;;                     #+(and abcl unix) "/tmp/rel/foo.lisp"
     1054;;                     #+(and allegro unix) "/tmp/foo.lisp"
     1055;;                     #+(and allegro windows) "\\tmp\\foo.lisp"
     1056;;                     #-(or allegro abcl) "/tmp/rel/foo.lisp"
     1057                    #+abcl "/tmp/rel/foo.lisp"
     1058                    #+allegro "/tmp/foo.lisp"
     1059                    #-(or allegro abcl) "/tmp/rel/foo.lisp"
     1060                    )
    9941061  t)
    9951062
    9961063(setf (logical-pathname-translations "demo2")
    9971064      '(("test;**;*.*" "/tmp/demo2/test")))
     1065
    9981066(deftest sbcl.9
    9991067  (equal (enough-namestring "demo2:test;foo.lisp")
     
    10021070         #+allegro-v7.0 "demo2:test;foo.lisp"
    10031071         #+allegro-v6.2 "/test/foo.lisp" ;; BUG
    1004          #+clisp "TEST;FOO.LISP")
     1072         #+(and clisp unix) "TEST;FOO.LISP"
     1073         #+(and clisp windows) "DEMO2:TEST;FOO.LISP")
    10051074  t)
    10061075
     
    10541123(deftest sbcl.17
    10551124  #+allegro ;; BUG
    1056   (equal (namestring (translate-logical-pathname "bazooka:todemo;x.y")) "/tmp/todemo/x.y")
     1125  (check-namestring (translate-logical-pathname "bazooka:todemo;x.y") "/tmp/todemo/x.y")
    10571126  #+clisp ;; BUG
    10581127  (signals-error (translate-logical-pathname "bazooka:todemo;x.y") 'error)
    10591128  #-(or allegro clisp)
    1060   (equal (namestring (translate-logical-pathname "bazooka:todemo;x.y"))
    1061          #-windows "/tmp/x.y"
    1062          #+windows "\\tmp\\x.y")
    1063   t)
     1129  (check-namestring (translate-logical-pathname "bazooka:todemo;x.y") "/tmp/x.y")
     1130  t)
     1131
    10641132(deftest sbcl.18
    10651133  #+clisp ;; BUG
     
    10871155  (string-equal (host-namestring (parse-namestring "OTHER-HOST:ILLEGAL/LPN")) "OTHER-HOST")
    10881156  nil)
    1089 #+lispworks
     1157#+(or lispworks (and clisp windows))
    10901158(pushnew 'sbcl.21 *expected-failures*)
    10911159
     
    10931161  (string= (pathname-name (parse-namestring "OTHER-HOST:ILLEGAL/LPN")) "LPN")
    10941162  t)
     1163#+(and clisp windows)
     1164(pushnew 'sbcl.22 *expected-failures*)
    10951165
    10961166(setf (logical-pathname-translations "test0")
     
    11901260  (check-merge-pathnames #p"scratch:;foo" #p"/usr/local/doc/"
    11911261                         #-(or allegro clisp lispworks) #P"SCRATCH:USR;LOCAL;DOC;FOO"
    1192                          #+allegro #p"/usr/local/doc/foo"
     1262                         #+(and allegro unix) #p"/usr/local/doc/foo"
     1263                         #+(and allegro windows) #p"scratch:usr;local;doc;foo"
    11931264                         #+clisp #p"SCRATCH:;FOO"
    11941265                         #+lispworks #p"SCRATCH:FOO")
     
    12101281                         #-(or allegro clisp lispworks)
    12111282                         #p"SCRATCH:DIR;SUPPLIED-NAME.TYPE"
    1212                          #+allegro
     1283                         #+(and allegro unix)
    12131284                         #p"/usr/local/doc/supplied-name.type"
     1285                         #+(and allegro windows)
     1286                         #P"scratch:dir;supplied-name.type"
    12141287                         #+clisp
    12151288                         ;; #P"SCRATCH:;SUPPLIED-NAME.type.NEWEST"
     
    12311304                         #-(or allegro clisp lispworks)
    12321305                         #p"SCRATCH:DIR;NAME.SUPPLIED-TYPE"
    1233                          #+allegro
     1306                         #+(and allegro unix)
    12341307                         #p"/usr/local/doc/name.supplied-type"
     1308                         #+(and allegro windows)
     1309                         #P"scratch:dir;name.supplied-type"
    12351310                         #+clisp
    12361311                         ;; #P"SCRATCH:dir;name.supplied-type.NEWEST"
     
    12481323
    12491324(deftest sbcl.39
    1250   #-allegro
    1251   (check-merge-pathnames (make-pathname :host "scratch"
     1325  (let ((pathname (make-pathname :host "scratch"
    12521326                                        :directory '(:relative "foo")
    1253                                         :name "bar")
    1254                          #p"/aaa/bbb/ccc/ddd/eee"
    1255                          #-(or clisp lispworks)
    1256                          #p"SCRATCH:AAA;BBB;CCC;DDD;FOO;BAR"
    1257                          #+clisp
    1258                          ;; #P"SCRATCH:;foo;bar"
    1259                          (make-pathname :host "SCRATCH"
    1260                                         :directory '(:relative "foo")
    1261                                         :name "bar")
    1262                          #+lispworks
    1263                          #p"SCRATCH:FOO;BAR")
    1264   #+allegro
    1265   (signals-error (merge-pathnames (make-pathname :host "scratch"
    1266                                                  :directory '(:relative "foo")
    1267                                                  :name "bar")
    1268                                   #p"/aaa/bbb/ccc/ddd/eee")
    1269                  'error)
    1270   t)
    1271 
     1327                                        :name "bar"))
     1328        (default-pathname #p"/aaa/bbb/ccc/ddd/eee"))
     1329    #-allegro
     1330    (check-merge-pathnames pathname default-pathname
     1331                           #-(or clisp lispworks)
     1332                           #p"SCRATCH:AAA;BBB;CCC;DDD;FOO;BAR"
     1333                           #+clisp
     1334                           ;; #P"SCRATCH:;foo;bar"
     1335                           (make-pathname :host "SCRATCH"
     1336                                          :directory '(:relative "foo")
     1337                                          :name "bar")
     1338                           #+lispworks
     1339                           #p"SCRATCH:FOO;BAR")
     1340    #+(and allegro unix)
     1341    (signals-error (merge-pathnames pathname default-pathname) 'error)
     1342    #+(and allegro windows)
     1343    (check-merge-pathnames pathname default-pathname
     1344                           #P"scratch:aaa;bbb;ccc;ddd;foo;bar"))
     1345  t)
     1346
     1347#-(and lispworks windows)
    12721348(deftest sbcl.40
    1273   #-(or allegro lispworks)
    1274   (check-merge-pathnames (make-pathname :host "scratch"
    1275                                         :directory '(:relative :back "foo")
    1276                                         :name "bar")
    1277                          #p"/aaa/bbb/ccc/ddd/eee"
    1278                          #-clisp #p"SCRATCH:AAA;BBB;CCC;FOO;BAR"
    1279                          #+clisp
    1280                          ;; #P"SCRATCH:;..;foo;bar.NEWEST"
    1281                          (make-pathname :host "SCRATCH"
    1282                                         :directory '(:relative :back "foo")
    1283                                         :name "bar"))
    1284   #+(or allegro lispworks)
    1285   (signals-error (merge-pathnames (make-pathname :host "scratch"
    1286                                                  :directory '(:relative :back "foo")
    1287                                                  :name "bar")
    1288                          #p"/aaa/bbb/ccc/ddd/eee")
     1349  (let ((pathname (make-pathname :host "scratch"
     1350                                 :directory '(:relative :back "foo")
     1351                                 :name "bar"))
     1352        (default-pathname #p"/aaa/bbb/ccc/ddd/eee"))
     1353    #-(or allegro lispworks)
     1354    (check-merge-pathnames pathname default-pathname
     1355                           #-clisp #p"SCRATCH:AAA;BBB;CCC;FOO;BAR"
     1356                           #+clisp
     1357                           ;; #P"SCRATCH:;..;foo;bar.NEWEST"
     1358                           (make-pathname :host "SCRATCH"
     1359                                          :directory '(:relative :back "foo")
     1360                                          :name "bar"))
     1361    #+(or (and allegro unix) lispworks)
     1362    (signals-error (merge-pathnames pathname default-pathname) 'error)
     1363    #+(and allegro windows)
     1364    (check-merge-pathnames pathname default-pathname
     1365                           #P"scratch:aaa;bbb;ccc;foo;bar"))
     1366  t)
     1367
     1368#+(and lispworks windows)
     1369;; "Illegal logical pathname directory component: :BACK."
     1370(deftest sbcl.40
     1371  (signals-error (make-pathname :host "scratch"
     1372                                :directory '(:relative :back "foo")
     1373                                :name "bar")
    12891374                 'error)
    12901375  t)
     
    14151500  (string= (with-standard-io-syntax (write-to-string #p"/foo"))
    14161501           #-windows "#P\"/foo\""
    1417            #+windows "#P\"\\\\foo\"")
     1502           #+(and windows (not lispworks)) "#P\"\\\\foo\""
     1503           #+(and windows lispworks) "#P\"/foo\"")
    14181504  t)
    14191505
     
    14221508  (string= (with-standard-io-syntax (write-to-string #p"/foo" :readably nil))
    14231509           #-windows "#P\"/foo\""
    1424            #+windows "#P\"\\\\foo\"")
     1510           #+(and windows (not lispworks)) "#P\"\\\\foo\""
     1511           #+(and windows lispworks) "#P\"/foo\"")
    14251512  t)
    14261513
     
    14291516  (string= (with-standard-io-syntax (write-to-string #p"/foo" :escape nil))
    14301517           #-windows "#P\"/foo\""
    1431            #+windows "#P\"\\\\foo\"")
     1518           #+(and windows (not lispworks)) "#P\"\\\\foo\""
     1519           #+(and windows lispworks) "#P\"/foo\"")
    14321520  t)
    14331521
     
    14351523  (string= (with-standard-io-syntax (write-to-string #p"/foo" :readably nil :escape nil))
    14361524           #-windows "/foo"
    1437            #+windows "\\\\foo")
     1525           #+windows "\\foo")
    14381526  t)
    14391527
Note: See TracChangeset for help on using the changeset viewer.