Changeset 8951


Ignore:
Timestamp:
Mar 30, 2008, 8:03:15 AM (11 years ago)
Author:
gb
Message:

More Windows conditionaliztion. Strip drive: from pathnames obtained
from OS, turn backslashes to forward slashes in such pathames.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/win64/level-1/linux-files.lisp

    r8726 r8951  
    3535#+windows-target
    3636(progn
     37
     38(defun strip-drive-for-now (string)
     39  (or (and (> (length string) 2)
     40           (eql (schar string 1) #\:)
     41           (subseq string 2))
     42      string))
     43           
     44
     45(defun nbackslash-to-forward-slash (namestring)
     46  (dotimes (i (length namestring) namestring)
     47    (when (eql (schar namestring i) #\\)
     48      (setf (schar namestring i) #\/))))
     49
    3750(defconstant univeral-time-start-in-windows-seconds 9435484800)
    3851
    39 (defun windows-filetime-to-universal-time (filetime)
     52(defun windows-filetime-to-universal-time (ft)
    4053  (let* ((100-ns (dpb (pref ft #>FILETIME.dwHighDateTime) (byte 32 32)
    4154                      (pref ft #>FILETIME.dwLowDateTime)))
     
    4356    (- seconds-since-windows-epoch univeral-time-start-in-windows-seconds)))
    4457)
     58
    4559
    4660(defun get-foreign-namestring (pointer)
     
    5165  #+darwin-target
    5266  (precompose-simple-string (%get-utf-8-cstring pointer))
    53   #+windows-target (%get-native-utf-16-cstring pointer)
     67  #+windows-target (strip-drive-for-now
     68                    (nbackslash-to-forward-slash
     69                     (%get-native-utf-16-cstring pointer)))
    5470  ;; On some other platforms, the namestring is assumed to
    5571  ;; be encoded according to the current locale's character
     
    5773  ;; precomposed UTF-8.).
    5874  ;; In any case, the use of %GET-CSTRING here is wrong ...
    59   #-(or darwin-target windows-taget)
     75  #-(or darwin-target windows-target)
    6076  (%get-cstring pointer))
    6177
     
    175191  ;;        N < bufsize: success, string is of length n
    176192  ;;        N > bufsize: buffer needs to be larger.
    177   (let* ((p (#_getcwd buf bufsize)))
     193  (let* ((p (#+windows-target #__wgetcwd #-windows-target #_getcwd buf bufsize)))
    178194    (declare (dynamic-extent p))
    179195    (if (%null-ptr-p p)
     
    182198          (+ bufsize bufsize)
    183199          err))
     200      #+windows-target
     201      (do* ((i 0 (+ i 2)))
     202           ((= i bufsize) (+ bufsize))
     203        (when (eql (%get-unsigned-word buf i) 0)
     204          (return (ash i -1))))
     205      #-windows-target
    184206      (dotimes (i bufsize (+ bufsize bufsize))
    185207        (when (eql 0 (%get-byte buf i))
     
    195217               (cond ((< len 0) (%errno-disp len bufsize))
    196218                     ((< len bufsize)
     219                      #+windows-target
     220                      (setf (%get-unsigned-word buf (+ len len)) 0)
     221                      #-windows-target
    197222                      (setf (%get-unsigned-byte buf len) 0)
    198223                      (values (get-foreign-namestring buf) len))
     
    216241
    217242(defmacro with-filename-cstrs (&rest rest)
    218   `(#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ,@rest))
     243  `(#+darwin-target with-utf-8-cstrs
     244    #+windows-target with-native-utf-16-cstrs
     245    #-(or darwin-target windows-target) with-cstrs ,@rest))
     246
     247(defmacro int-errno-call (form)
     248  (let* ((result (gensym)))
     249   `(let* ((,result ,form))
     250     (if (< ,result 0)
     251       (%get-errno)
     252       ,result))))
    219253
    220254(defun %chdir (dirname)
    221255  (with-filename-cstrs ((dirname dirname))
    222     (syscall syscalls::chdir dirname)))
     256    (int-errno-call (#+windows-target #__wchdir #-windows-target #_chdir dirname))))
    223257
    224258(defun %mkdir (name mode)
     259  #+windows-target (declare (ignore mode))
    225260  (let* ((name name)
    226261         (len (length name)))
     
    228263      (setq name (subseq name 0 (1- len))))
    229264    (with-filename-cstrs ((name name))
    230       (syscall syscalls::mkdir name mode))))
     265      (int-errno-call (#+windows-target #__wmkdir #-windows-target #_mkdir  name #-windows-target mode)))))
    231266
    232267(defun %rmdir (name)
    233   (let* ((last (1- (length name))))
     268  (let* ((name name)
     269         (len (length name)))
     270    (when (and (> len 0)
     271               (eql (char name (1- len)) #\/))
     272      (setq name (subseq name 0 (1- len))))
    234273    (with-filename-cstrs ((name name))
    235       (when (and (>= last 0)
    236                  (eql (%get-byte name last) (char-code #\/)))
    237         (setf (%get-byte name last) 0))
    238     (syscall syscalls::rmdir name))))
     274      (int-errno-call (#+windows-target #__wrmdir #-windows-target #_rmdir  name)))))
    239275
    240276
     
    253289  "Set the value of the environment variable named by name, in the OS
    254290environment. If there is no such environment variable, create it."
     291  #+windows-target (declare (ignore overwrite))
     292  #-windows-target
    255293  (with-cstrs ((ckey key)
    256294               (cvalue value))
    257     (#_setenv ckey cvalue (if overwrite 1 0))))
    258 
     295    (#_setenv ckey cvalue (if overwrite 1 0)))
     296  #+windows-target
     297  (with-cstrs ((pair (format nil "~a=~a" key value)))
     298    (#__putenv pair))
     299  )
     300
     301#-windows-target                        ; Windows "impersonation" crap ?
    259302(defun setuid (uid)
    260303  "Attempt to change the current user ID (both real and effective);
     
    263306  (syscall syscalls::setuid uid))
    264307
     308#-windows-target
    265309(defun setgid (uid)
    266310  "Attempt to change the current group ID (both real and effective);
     
    274318;;; they're talking about.
    275319
     320#-windows-target
    276321(defun %stat-values (result stat)
    277322  (if (eql 0 (the fixnum result))
     
    294339      (values nil nil nil nil nil nil nil)))
    295340
     341#+win64-target
     342(defun %stat-values (result stat)
     343  (if (eql 0 (the fixnum result))
     344      (values
     345       t
     346       (pref stat :stat.st_mode)
     347       (pref stat :stat.st_size)
     348       (pref stat :stat.st_mtime)
     349       (pref stat :stat.st_ino)
     350       (pref stat :stat.st_uid)
     351       #$BUFSIZ
     352       (pref stat :stat.st_mtime)
     353       (pref stat :stat.st_gid))
     354      (values nil nil nil nil nil nil nil nil nil)))
    296355
    297356(defun %%stat (name stat)
     
    301360     (#_ __xstat #$_STAT_VER_LINUX cname stat)
    302361     #-linux-target
    303      (syscall syscalls::stat cname stat)
     362     (int-errno-call (#+windows-target #__wstat64 #-windows-target #_stat cname stat))
    304363     stat)))
    305364
     
    309368   (#_ __fxstat #$_STAT_VER_LINUX fd stat)
    310369   #-linux-target
    311    (syscall syscalls::fstat fd stat)
     370   (int-errno-call (#+windows-target #__fstat64 #-windows-target #_fstat fd stat))
    312371   stat))
    313372
     373#-windows-target
    314374(defun %%lstat (name stat)
    315375  (with-filename-cstrs ((cname name))
     
    326386;;; NAME should be a "native namestring", e.g,, have all lisp pathname
    327387;;; escaping removed.
     388#-windows-target
    328389(defun %stat (name &optional link-p)
    329   (rlet ((stat :stat))
     390  (rlet ((stat  :stat))
    330391    (if link-p
    331392      (%%lstat name stat)
    332393      (%%stat name stat))))
     394
     395#+windows-target
     396(defun %stat (name &optional link-p)
     397  (declare (ignore link-p))
     398  (rlet ((stat  #+win64-target #>_stat64))
     399    (%%stat name stat)))
    333400
    334401(defun %fstat (fd)
     
    342409      (cond ((eql kind #$S_IFDIR) :directory)
    343410            ((eql kind #$S_IFREG) :file)
     411            #-windows-target
    344412            ((eql kind #$S_IFLNK) :link)
    345413            ((eql kind #$S_IFIFO) :pipe)
     414            #-windows-target
    346415            ((eql kind #$S_IFSOCK) :socket)
    347416            ((eql kind #$S_IFCHR) :character-special)
     
    356425    (%file-kind (nth-value 1 (%fstat fd)))))
    357426
     427#-windows-target
    358428(defun %uts-string (result idx buf)
    359429  (if (eql 0 result)
     
    363433    "unknown"))
    364434
     435#-windows-target
    365436(defun copy-file-attributes (source-path dest-path)
    366437  "Copy the mode, owner, group and modification time of source-path to dest-path.
     
    408479
    409480(defun fd-dup (fd)
    410   (syscall syscalls::dup fd))
     481  (int-errno-call (#_dup fd)))
    411482
    412483(defun fd-fsync (fd)
    413   (syscall syscalls::fsync fd))
    414 
     484  #+windows-target (progn fd 0)
     485  #-windows-target
     486  (int-errno-call (#_fsync fd)))
     487
     488#-windows-target
     489(progn
    415490(defun fd-get-flags (fd)
    416491  (syscall syscalls::fcntl fd #$F_GETFL))
     
    430505      old
    431506      (fd-set-flags fd (logandc2 old mask)))))
    432 
     507)
    433508
    434509;;; Assume that any quoting's been removed already.
     
    447522          (concatenate 'string (get-user-home-dir uid) (if slash-pos (subseq namestring slash-pos) "/")))))))
    448523
    449                      
     524
     525#+windows-target
     526(defun %windows-realpath (namestring)
     527  (let* ((len (length namestring))
     528         (real
     529          (if (< len 2)
     530            namestring
     531            (let* ((c0 (schar namestring 0))
     532                   (c1 (schar namestring 1)))
     533              (if (or (eql c0 #\/)
     534                      (eql c0 #\\)
     535                      (eql c1 #\:))
     536                namestring
     537                (concatenate 'string (current-directory-name) "/" namestring))))))
     538    (when (%stat real)
     539      real)))
    450540   
    451541;;; This doesn't seem to exist on VxWorks.  It's a POSIX
     
    453543
    454544(defun %realpath (namestring)
     545  ;; It's not at all right to just return the namestring here.
    455546  (when (zerop (length namestring))
    456547    (setq namestring (current-directory-name)))
     548  #+windows-target (%windows-realpath namestring)
     549  #-windows-target
    457550  (%stack-block ((resultbuf #$PATH_MAX))
    458551    (with-filename-cstrs ((name namestring #|(tilde-expand namestring)|#))
     
    506599
    507600
     601#-windows-target
    508602(defun %%rusage (usage &optional (who #$RUSAGE_SELF))
    509603  (syscall syscalls::getrusage who usage))
    510 
    511604
    512605
     
    517610      (+ date unix-to-universal-time))))
    518611
     612#-windows-target
    519613(defun %file-author (namestring)
    520614  (let* ((uid (nth-value 5 (%stat namestring))))
     
    525619           (%get-cstring (pref pw :passwd.pw_name))))))))
    526620
     621#-windows-target
    527622(defun %utimes (namestring)
    528623  (with-filename-cstrs ((cnamestring namestring))
     
    533628         
    534629
     630#-windows-target
    535631(defun get-uid-from-name (name)
    536632  (with-cstrs ((name name))
     
    539635        (pref pwent :passwd.pw_uid)))))
    540636
    541    
     637
    542638(defun isatty (fd)
     639  #+windows-target (declare (ignore fd))
     640  #+windows-target nil
     641  #-windows-target
    543642  (= 1 (#_isatty fd)))
    544643
     
    557656      (get-foreign-namestring (pref res :dirent.d_name)))))
    558657
     658#-windows-target
    559659(defun tcgetpgrp (fd)
    560660  (#_tcgetpgrp fd))
     
    562662(defun getpid ()
    563663  "Return the ID of the OpenMCL OS process."
    564   (syscall syscalls::getpid))
     664  (int-errno-call (#_getpid)))
    565665
    566666(defun getuid ()
    567667  "Return the (real) user ID of the current user."
    568   (syscall syscalls::getuid))
     668  #+windows-target 0
     669  #-windows-target (int-errno-all (#_getuid)))
    569670
    570671(defun get-user-home-dir (userid)
     
    572673by uid. This value comes from the OS user database, not from the $HOME
    573674environment variable. Returns NIL if there is no user with the ID uid."
     675  #+windows-target
     676  (let* ((homedrive (getenv "HOMEDRIVE"))
     677         (homepath (getenv "HOMEPATH")))
     678    (and homedrive homepath (concatenate 'string homedrive homepath)))
     679  #-windows-target
    574680  (rlet ((pwd :passwd)
    575681         (result :address))
     
    585691(defun %delete-file (name)
    586692  (with-cstrs ((n name))
    587     (syscall syscalls::unlink n)))
     693    (int-errno-call (#_unlink n))))
    588694
    589695(defun os-command (string)
     
    706812  `(call-with-string-vector #'(lambda (,var) ,@body) ,@strings))
    707813
    708 (defloadvar *max-os-open-files* (#_getdtablesize))
    709 
     814(defloadvar *max-os-open-files* #-windows-target (#_getdtablesize) #+windows-target 32)
     815
     816#-windows-target
     817(progn
    710818(defun %execvp (argv)
    711819  (#_execvp (%get-ptr argv) argv)
     
    721829    (declare (fixnum fd))
    722830    (#_close fd)))
    723 
    724831
    725832
     
    11281235    (t nil)))
    11291236
     1237)
    11301238
    11311239(defstruct (shared-resource (:constructor make-shared-resource (name)))
     
    12811389                  (pref ret :uint)
    12821390                  1))))
    1283             )))
     1391            #+windows-target
     1392              (rlet ((bufsize #>DWORD 64))
     1393                (loop
     1394                  (%stack-block ((info (pref bufsize #>DWORD)))
     1395                    (unless (eql #$FALSE (#_GetLogicalProcessorInformation
     1396                                          info bufsize))
     1397                      (let* ((count 0)
     1398                             (nbytes (pref bufsize #>DWORD)))
     1399                        (return
     1400                          (do* ((i 0 (+ i (record-length #>SYSTEM_LOGICAL_PROCESSOR_INFORMATION))))
     1401                               ((>= i nbytes) count)
     1402                            (when (eql (pref info #>SYSTEM_LOGICAL_PROCESSOR_INFORMATION.Relationship) #$RelationProcessorCore)
     1403                              (incf count))
     1404                            (%incf-ptr info (record-length #>SYSTEM_LOGICAL_PROCESSOR_INFORMATION))))))))))))
    12841405
    12851406(def-load-pointers spin-count ()
     
    12901411
    12911412(defun yield ()
     1413  #+windows-target
     1414  (#_Sleep 0)
     1415  #-windows-target 
    12921416  (#_sched_yield))
    12931417
    1294 (defloadvar *host-page-size* (#_getpagesize))
     1418(defloadvar *host-page-size*
     1419    #-windows-target (#_getpagesize)
     1420    #+windows-target
     1421    (rlet ((info #>SYSTEM_INFO))
     1422      (#_GetSystemInfo info)
     1423      (pref info #>SYSTEM_INFO.dwPageSize))
     1424    )
    12951425
    12961426;;(assert (= (logcount *host-page-size*) 1))
    12971427
     1428#-windows-target
     1429(progn
    12981430(defun map-file-to-ivector (pathname element-type)
    12991431  (let* ((upgraded-type (upgraded-array-element-type element-type))
     
    14681600      (mapped-vector-data-address-and-size v)
    14691601    (percentage-of-resident-pages address nbytes)))
     1602)
    14701603 
    14711604#+x86-target
Note: See TracChangeset for help on using the changeset viewer.