Changeset 8843


Ignore:
Timestamp:
Mar 21, 2008, 10:36:31 AM (11 years ago)
Author:
gb
Message:

Flesh out/fix the #+windows-target stuff.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/win64/level-0/l0-cfm-support.lisp

    r8737 r8843  
    460460  ) 
    461461
    462 #||
     462#+windows-target
    463463(progn
    464   (defvar *current-process-handle* (ff-call (foreign-symbol-entry "GetCurrentProcess") :address))
    465   (defvar *enum-process-modules-addr* (foreign-symbol-entry "EnumProcessModules"))
    466   (defvar *get-module-file-name-addr* (foreign-symbol-entry "GetModuleFileName"))
    467   (defvar *get-module-base-name-addr* (foreign-symbol-entry "GetModuleBaseName"))
    468   (defvar *get-module-handle-ex-addr* (foreign-symbol-entry "GetModuleHandleEx"))
     464  (defvar *current-process-handle*)
     465  (defvar *enum-process-modules-addr*)
     466  (defvar *get-module-file-name-addr*)
     467  (defvar *get-module-base-name-addr*)
     468  (defvar *get-module-handle-ex-addr*)
     469
     470
     471  (defun init-windows-ffi ()
     472    (setq *current-process-handle* (ff-call (foreign-symbol-entry "GetCurrentProcess") :address))
     473    (setq *enum-process-modules-addr* (foreign-symbol-entry "EnumProcessModules"))   
     474    (setq *get-module-file-name-addr* (foreign-symbol-entry "GetModuleFileNameA"))
     475    (setq *get-module-base-name-addr* (foreign-symbol-entry "GetModuleBaseNameA"))
     476    (setq *get-module-handle-ex-addr* (foreign-symbol-entry "GetModuleHandleExA")))
     477
     478  (init-windows-ffi)
    469479 
    470480  (defun hmodule-pathname (hmodule)
     
    475485                                :address *current-process-handle*
    476486                                :address hmodule
    477                                 :address buf
    478                                 :signed-fullword bufsize)))
     487                                :address name
     488                                :signed-fullword bufsize
     489                                :signed-fullword)))
    479490          (if (eql 0 needed)
    480491            (return nil)
    481492            (if (< bufsize needed)
    482493              (setq bufsize needed)
    483               (%str-from-ptr buf needed)))))))
     494              (return (%str-from-ptr name needed))))))))
    484495
    485496  (defun hmodule-basename (hmodule)
     
    490501                                :address *current-process-handle*
    491502                                :address hmodule
    492                                 :address buf
    493                                 :signed-fullword bufsize)))
     503                                :address name
     504                                :signed-fullword bufsize
     505                                :signed-fullword)))
    494506          (if (eql 0 needed)
    495507            (return nil)
    496508            (if (< bufsize needed)
    497509              (setq bufsize needed)
    498               (%str-from-ptr buf needed)))))))
     510              (return (%str-from-ptr name needed))))))))
    499511
    500512  (defun existing-shlib-for-hmodule (hmodule)
     
    512524          shlib)))
    513525
     526  (defun for-each-loaded-module (f)
     527    (let* ((have (* 16 (record-length #>HMODULE))))
     528      (rlet ((pneed #>DWORD))
     529        (loop
     530          (%stack-block ((modules have))
     531            (ff-call *enum-process-modules-addr*
     532                     :address *current-process-handle*
     533                     :address modules
     534                     #>DWORD have
     535                     :address pneed)
     536            (let* ((need (pref pneed #>DWORD)))
     537              (if (> need have)
     538                (setq have need)
     539                (return
     540                  (do* ((i 0 (+ i (record-length #>HMODULE))))
     541                       ((= i need))
     542                    (funcall f (%get-ptr modules i)))))))))))
     543
     544  (defun init-shared-libraries ()
     545    (for-each-loaded-module #'shared-library-from-hmodule))
     546 
    514547  (defun shlib-containing-entry (addr &optional name)
    515     (shlib-containing-address addr name))
     548    (with-macptrs ((p (%int-to-ptr addr)))
     549      (shlib-containing-address p name)))
    516550
    517551  (defun shlib-containing-address (addr &optional name)
     
    519553    (rlet ((phmodule :address +null-ptr+))
    520554      (let* ((found (ff-call *get-module-handle-ex-addr*
    521                              :>DWORD (logior
    522                                       GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS
    523                                       GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT)
     555                             #>DWORD (logior
     556                                      #$GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS
     557                                      #$GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT)
    524558                             :address addr
    525559                             :address phmodule
    526                              :>BOOL)))
     560                             #>BOOL)))
    527561        (unless (eql 0 found)
    528562          (let* ((hmodule (pref phmodule :address)))
     
    530564              (when (eql (shlib.map lib)  hmodule)
    531565                (return lib))))))))
     566
    532567
    533568  (defun open-shared-library (name)
     
    552587        (error "Can't open shared library ~s" name))))
    553588
    554   (defun iterate-over-hmodules (f)
    555     ;; El-bizarro Windows interface
    556     (%stack-block ((pcbneeded 4))       ; sizeof #>DWORD
    557       (do* ((cb 64))
    558            ()
    559         (%stack-block ((modules cbneeded))
    560           (ff-call *enum-process-modules-addr*
    561                    :address *current-process-handle*
    562                    :address modules
    563                    #>DWORD cb
    564                    :address pcbneeded)
    565           (let* ((cbneeded (pref pcbneeded #>DWORD)))
    566             (if (< cb cbneeded)
    567               (setq cb cbneeded)
    568               (let* ((nmodules (%fixnum-floor cbneeded (record-length #>HMODULE))))
    569                
    570  
     589(init-shared-libraries)
    571590
    572591;;; end windows-target
    573592
    574 ||#
     593
    575594
    576595(defun ensure-open-shlib (c force)
     
    642661  (unless *statically-linked*
    643662    (with-macptrs (p)
    644       (%setf-macptr-to-object p entry)
     663      #+ppc-target (%setf-macptr-to-object p entry)
     664      #+x86-target (%setf-macptr p (%int-to-ptr entry))
    645665      (shlib-containing-address p name))))
    646666)
Note: See TracChangeset for help on using the changeset viewer.