home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / foreign.lisp < prev    next >
Encoding:
Text File  |  1992-07-28  |  7.2 KB  |  217 lines
  1. ;;; -*- Package: SYSTEM -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: foreign.lisp,v 1.12 92/07/17 16:03:41 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. (in-package "SYSTEM")
  15.  
  16. (in-package "ALIEN")
  17. (export '(load-foreign))
  18. (in-package "SYSTEM")
  19. (import 'alien:load-foreign)
  20.  
  21. (defvar *previous-linked-object-file* nil)
  22. (defvar *foreign-segment-free-pointer* foreign-segment-start)
  23.  
  24. (defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C"))
  25.   (let ((code (char-code #\A)))
  26.     (loop
  27.       (let ((name (format nil base (unix:unix-getpid) (code-char code))))
  28.     (multiple-value-bind
  29.         (fd errno)
  30.         (unix:unix-open name
  31.                 (logior unix:o_wronly unix:o_creat unix:o_excl)
  32.                 #o666)
  33.       (cond ((not (null fd))
  34.          (unix:unix-close fd)
  35.          (return name))
  36.         ((not (= errno unix:eexist))
  37.          (error "Could not create temporary file ~S: ~A"
  38.             name (unix:get-unix-error-msg errno)))
  39.         
  40.         ((= code (char-code #\Z))
  41.          (setf code (char-code #\a)))
  42.         ((= code (char-code #\z))
  43.          (return nil))
  44.         (t
  45.          (incf code))))))))
  46.  
  47. #+sparc
  48. (alien:def-alien-type exec
  49.   (alien:struct nil
  50.     (magic c-call:unsigned-long)
  51.     (text c-call:unsigned-long)
  52.     (data c-call:unsigned-long)
  53.     (bss c-call:unsigned-long)
  54.     (syms c-call:unsigned-long)
  55.     (entry c-call:unsigned-long)
  56.     (trsize c-call:unsigned-long)
  57.     (drsize c-call:unsigned-long)))
  58.  
  59. (defun allocate-space-in-foreign-segment (bytes)
  60.   (let* ((pagesize-1 (1- (get-page-size)))
  61.      (memory-needed (logandc2 (+ bytes pagesize-1) pagesize-1))
  62.      (addr (int-sap *foreign-segment-free-pointer*))
  63.      (new-ptr (+ *foreign-segment-free-pointer* bytes)))
  64.     (when (> new-ptr (+ foreign-segment-start foreign-segment-size))
  65.       (error "Not enough memory left."))
  66.     (setf *foreign-segment-free-pointer* new-ptr)
  67.     (allocate-system-memory-at addr memory-needed)
  68.     addr))
  69.  
  70. #+sparc
  71. (defun load-object-file (name)
  72.   (format t ";;; Loading object file...~%")
  73.   (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
  74.     (unless fd
  75.       (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
  76.     (unwind-protect
  77.     (alien:with-alien ((header exec))
  78.       (unix:unix-read fd
  79.               (alien:alien-sap header)
  80.               (alien:alien-size exec :bytes))
  81.       (let* ((len-of-text-and-data
  82.           (+ (alien:slot header 'text) (alien:slot header 'data)))
  83.          (memory-needed
  84.           (+ len-of-text-and-data (alien:slot header 'bss)))
  85.          (addr (allocate-space-in-foreign-segment memory-needed)))
  86.         (unix:unix-read fd addr len-of-text-and-data)))
  87.       (unix:unix-close fd))))
  88.  
  89. #+pmax
  90. (alien:def-alien-type filehdr
  91.   (alien:struct nil
  92.     (magic c-call:unsigned-short)
  93.     (nscns c-call:unsigned-short)
  94.     (timdat c-call:long)
  95.     (symptr c-call:long)
  96.     (nsyms c-call:long)
  97.     (opthdr c-call:unsigned-short)
  98.     (flags c-call:unsigned-short)))
  99.  
  100. #+pmax
  101. (alien:def-alien-type aouthdr
  102.   (alien:struct nil
  103.     (magic c-call:short)
  104.     (vstamp c-call:short)
  105.     (tsize c-call:long)
  106.     (dsize c-call:long)
  107.     (bsize c-call:long)
  108.     (entry c-call:long)
  109.     (text_start c-call:long)
  110.     (data_start c-call:long)))
  111.  
  112. #+pmax
  113. (defconstant filhsz 20)
  114. #+pmax
  115. (defconstant aouthsz 56)
  116. #+pmax
  117. (defconstant scnhsz 40)
  118.  
  119. #+pmax
  120. (defun load-object-file (name)
  121.   (format t ";;; Loading object file...~%")
  122.   (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
  123.     (unless fd
  124.       (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
  125.     (unwind-protect
  126.     (alien:with-alien ((filehdr filehdr)
  127.                (aouthdr aouthdr))
  128.       (unix:unix-read fd
  129.               (alien:alien-sap filehdr)
  130.               (alien:alien-size filehdr :bytes))
  131.       (unix:unix-read fd
  132.               (alien:alien-sap aouthdr)
  133.               (alien:alien-size aouthdr :bytes))
  134.       (let* ((len-of-text-and-data
  135.           (+ (alien:slot aouthdr 'tsize) (alien:slot aouthdr 'dsize)))
  136.          (memory-needed
  137.           (+ len-of-text-and-data (alien:slot aouthdr 'bsize)))
  138.          (addr (allocate-space-in-foreign-segment memory-needed))
  139.          (pad-size-1 (if (< (alien:slot aouthdr 'vstamp) 23) 7 15)))
  140.         (unix:unix-lseek fd
  141.                  (logandc2 (+ filhsz aouthsz
  142.                       (* scnhsz
  143.                          (alien:slot filehdr 'nscns))
  144.                       pad-size-1)
  145.                        pad-size-1)
  146.                  unix:l_set)
  147.         (unix:unix-read fd addr len-of-text-and-data)))
  148.       (unix:unix-close fd))))
  149.  
  150. (defun parse-symbol-table (name)
  151.   (format t ";;; Parsing symbol table...~%")
  152.   (let ((symbol-table (make-hash-table :test #'equal)))
  153.     (with-open-file (file name)
  154.       (loop
  155.     (let ((line (read-line file nil nil)))
  156.       (unless line
  157.         (return))
  158.       (let* ((symbol (subseq line 11))
  159.          (address (parse-integer line :end 8 :radix 16))
  160.          (old-address (gethash symbol lisp::*foreign-symbols*)))
  161.         (unless (or (null old-address) (= address old-address))
  162.           (warn "~S moved from #x~8,'0X to #x~8,'0X.~%"
  163.             symbol old-address address))
  164.         (setf (gethash symbol symbol-table) address)))))
  165.     (setf lisp::*foreign-symbols* symbol-table)))
  166.  
  167. (defun load-foreign (files &key
  168.                (libraries '("-lc"))
  169.                (base-file
  170.                 (merge-pathnames *command-line-utility-name*
  171.                          "path:"))
  172.                (env ext:*environment-list*))
  173.   "Load-foreign loads a list of C object files into a running Lisp.  The files
  174.   argument should be a single file or a list of files.  The files may be
  175.   specified as namestrings or as pathnames.  The libraries argument should be a
  176.   list of library files as would be specified to ld.  They will be searched in
  177.   the order given.  The default is just \"-lc\", i.e., the C library.  The
  178.   base-file argument is used to specify a file to use as the starting place for
  179.   defined symbols.  The default is the C start up code for Lisp.  The env
  180.   argument is the Unix environment variable definitions for the invocation of
  181.   the linker.  The default is the environment passed to Lisp."
  182.   (let ((output-file (pick-temporary-file-name))
  183.     (symbol-table-file (pick-temporary-file-name))
  184.     (error-output (make-string-output-stream)))
  185.  
  186.     (format t ";;; Running library:load-foreign.csh...~%")
  187.     (force-output)
  188.     (let ((proc (ext:run-program "library:load-foreign.csh"
  189.                  (list* (or *previous-linked-object-file*
  190.                         (namestring (truename base-file)))
  191.                     (format nil "~X"
  192.                         *foreign-segment-free-pointer*)
  193.                     output-file
  194.                     symbol-table-file
  195.                     (append (if (atom files)
  196.                             (list files)
  197.                             files)
  198.                         libraries))
  199.                  :env env
  200.                  :input nil
  201.                  :output error-output
  202.                  :error :output)))
  203.       (unless proc
  204.     (error "Could not run library:load-foreign.csh"))
  205.       (unless (zerop (ext:process-exit-code proc))
  206.     (system:serve-all-events 0)
  207.     (error "library:load-foreign.csh failed:~%~A"
  208.            (get-output-stream-string error-output)))
  209.       (load-object-file output-file)
  210.       (parse-symbol-table symbol-table-file)
  211.       (unix:unix-unlink symbol-table-file)
  212.       (let ((old-file *previous-linked-object-file*))
  213.     (setf *previous-linked-object-file* output-file)
  214.     (when old-file
  215.       (unix:unix-unlink old-file)))))
  216.   (format t ";;; Done.~%"))
  217.