← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/ecl/intrepid

« back to all changes in this revision

Viewing changes to src/cmp/cmpname.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Albin Tonnerre
  • Date: 2008-06-20 18:00:19 UTC
  • mfrom: (1.1.4 upstream)
  • Revision ID: james.westby@ubuntu.com-20080620180019-7fbz1ln5444vtkkr
Tags: 0.9j-20080306-2ubuntu1
* Enabled unicode support. (Closes: LP #123530)
* Modify Maintainer value to match the DebianMaintainerField specification.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/cmp/cmpname.lsp
 
1
;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
 
2
;;;;
 
3
;;;;  Copyright (c) 2007, Juan Jose Garcia Ripoll.
 
4
;;;;
 
5
;;;;    This program is free software; you can redistribute it and/or
 
6
;;;;    modify it under the terms of the GNU Library General Public
 
7
;;;;    License as published by the Free Software Foundation; either
 
8
;;;;    version 2 of the License, or (at your option) any later version.
 
9
;;;;
 
10
;;;;    See file '../Copyright' for full details.
 
11
 
 
12
;;;; CMPNAME Unambiguous init names for object files
 
13
;;;;
 
14
;;;; Every object file in a lisp library or combined FASL (such as the
 
15
;;;; compiler), needs a function that creates its data and installs the
 
16
;;;; functions. This initialization function has a C name which needs
 
17
;;;; to be unique. This file has functions to create such names.
 
18
 
 
19
(in-package "COMPILER")
 
20
 
 
21
(defvar *counter* 0)
 
22
 
 
23
(defun encode-number-in-name (number)
 
24
  ;; Encode a number in an alphanumeric identifier which is a valid C name.
 
25
  (declare (si::c-local))
 
26
  (cond ((zerop number) "0")
 
27
        ((minusp number) (encode-number-in-name (- number)))
 
28
        (t
 
29
         (do* ((code "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")
 
30
               (base (length code))
 
31
               (output '())
 
32
               (digit 0))
 
33
              ((zerop number) (concatenate 'string (nreverse output)))
 
34
           (multiple-value-setq (number digit) (floor number base))
 
35
           (push (char code digit) output)))))
 
36
 
 
37
(defun unique-init-name (pathname)
 
38
  "Create a unique name for this initialization function. The current algorithm
 
39
relies only on the name of the source file and the time at which it is built. This
 
40
should be enough to prevent name collisions for object files built in the same
 
41
machine."
 
42
  (let ((tag (concatenate 'base-string
 
43
                          "_ecl"
 
44
                          (encode-number-in-name (sxhash pathname))
 
45
                          "_"
 
46
                          (encode-number-in-name (get-universal-time)))))
 
47
    (cmpnote "Creating tag: ~S for ~S" tag pathname)
 
48
    tag))
 
49
 
 
50
(defun init-name-tag (init-name)
 
51
  (concatenate 'base-string "@EcLtAg" ":" init-name "@"))
 
52
 
 
53
(defun search-tag (stream tag)
 
54
  (declare (si::c-local))
 
55
  (do* ((eof nil)
 
56
        (key (concatenate 'list tag ":"))
 
57
        (string key))
 
58
       (nil)
 
59
    (let ((c (read-char stream nil nil)))
 
60
      (cond ((null c) (return nil))
 
61
            ((not (equal c (pop string)))
 
62
             (setf string key))
 
63
            ((null string)
 
64
             (return t))))))
 
65
 
 
66
(defun read-name (stream)
 
67
  (declare (si::c-local))
 
68
  (concatenate 'string
 
69
               (loop with c = t
 
70
                  until (or (null (setf c (read-char stream nil nil)))
 
71
                            (equal c #\@))
 
72
                  collect c)))
 
73
 
 
74
(defun find-init-name (file &key (tag "@EcLtAg"))
 
75
  "Search for the initialization function in an object file. Since the
 
76
initialization function in object files have more or less unpredictable
 
77
names, we store them in a string in the object file. This string is recognized
 
78
by the TAG it has at the beginning This function searches that tag and retrieves
 
79
the function name it precedes."
 
80
  (with-open-file (stream file :direction :input)
 
81
    (cmpnote "Scanning ~S" file)
 
82
    (when (search-tag stream tag)
 
83
      (let ((name (read-name stream)))
 
84
        (cmpnote "Found tag: ~S" name)
 
85
        name))))
 
86
 
 
87
(defun remove-prefix (prefix name)
 
88
  (if (equal 0 (search prefix name))
 
89
      (subseq name (length prefix) nil)
 
90
      name))
 
91
 
 
92
(defun guess-init-name (pathname &key (kind (guess-kind pathname)))
 
93
  (let ((filename (pathname-name pathname)))
 
94
    (case kind
 
95
      ((:object :c)
 
96
       (or (and (probe-file pathname)
 
97
                (find-init-name pathname))
 
98
           (unique-init-name pathname)))
 
99
      ((:fasl :fas)
 
100
       (init-function-name "CODE" :kind :fas))
 
101
      ((:static-library :lib)
 
102
       (init-function-name (remove-prefix +static-library-prefix+ filename)
 
103
                           :kind :lib))
 
104
      ((:shared-library :dll)
 
105
       (init-function-name (remove-prefix +shared-library-prefix+ filename)
 
106
                           :kind :dll))
 
107
      ((:program)
 
108
       "init_ECL_PROGRAM")
 
109
      (otherwise
 
110
       (error "C::BUILDER cannot accept files of kind ~s" kind)))))