← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to comp/mangle.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
comp/mangle.lsp
 
1
(in-package "BCOMP")
 
2
;; Naming convention
 
3
;; <package>{f | s | q | l}<mangled_name>
 
4
;; where f = Function, s = Symbol , q = special form (Quote) , l= Lexical
 
5
;; eg fLcar, sLnil, fSallocate_internal,sLAstandard_outputA.qLprogn
 
6
 
 
7
(eval-when (load eval compile)
 
8
(defvar *mangle-base* (make-array 128 :element-type 'character))
 
9
(defvar *mangle-escapes*  (make-array 128 :element-type 'character))
 
10
(defmacro mangle-type (flag) `(position ',flag  '(octal self special-escape)))
 
11
(defvar *mangle-escape* #\E)
 
12
 
 
13
(sloop for i below 128 with tem
 
14
   for ch = (code-char i)
 
15
   
 
16
   do (setf (aref *mangle-escapes* i) (code-char 0))
 
17
   (setf (aref *mangle-base* i) (code-char (mangle-type octal)))
 
18
   (when (alphanumericp ch) (setf (aref *mangle-base* i)
 
19
                                 (if (upper-case-p ch) (char-downcase ch)
 
20
                                   (char-upcase ch)))))
 
21
 
 
22
(sloop for (v ch) in
 
23
    '((#\+ #\Q)(#\- #\_)(#\* #\A)(#\% #\P)
 
24
                                 (#\; #\X)(#\. #\Z)(#\, #\Y)
 
25
                                 (#\ #\E)
 
26
                                 (#\@ #\B)
 
27
                                 )
 
28
   do (setf (aref *mangle-base* (char-code v)) ch)
 
29
   (setf (aref *mangle-base* (char-code v))  ch)
 
30
   (setf (aref *mangle-base* (char-code (char-downcase ch)))
 
31
         (code-char (mangle-type special-escape)))
 
32
   (setf (aref *mangle-escapes* (char-code (char-downcase ch)))
 
33
         (char-downcase ch)))
 
34
(sloop for i from (char-code #\0) to (char-code #\9)
 
35
   for j from (char-code #\A)
 
36
   do (setf (aref *mangle-escapes* i) (code-char j)))
 
37
 
 
38
(defvar *mangle-out* (make-array 40 :element-type 'string-char :fill-pointer 0
 
39
                                 :adjustable t))
 
40
(proclaim '(string *mangle-out* *mangle-escapes* *mangle-base*))
 
41
(proclaim '(character *mangle-escape*))
 
42
)
 
43
 
 
44
 
 
45
(defun mangle(string)
 
46
  (let ((string
 
47
         (if (symbolp string) (symbol-name string)
 
48
           string)))
 
49
    (declare (string string))
 
50
    (let ((n (length string)) (start 0))
 
51
      (declare (fixnum n))
 
52
      (unless (> (array-total-size *mangle-out*)
 
53
                 (the fixnum (* 4 n)))
 
54
              (adjust-array *mangle-out* (* 4 n) :fill-pointer 0 ))
 
55
      (cond ((and (> n 0)
 
56
                  (digit-char-p (aref string 0)))
 
57
             (setf (aref *mangle-out*  0) *mangle-escape*)
 
58
             (setf (aref *mangle-out*  1)
 
59
                   (aref *mangle-escapes* (char-code (aref string 0))))
 
60
             (setf (fill-pointer *mangle-out*) 2)
 
61
             (incf start))
 
62
            (t       (setf (fill-pointer *mangle-out*) 0)))
 
63
      (sloop for i from start below n
 
64
         do (mangle1 (aref string i)))
 
65
      *mangle-out*)))
 
66
 
 
67
(defun mangle1 (ch )
 
68
  (declare (character ch))
 
69
  (let* ((tem (aref *mangle-base* (char-code ch)))
 
70
         (n (char-code tem))
 
71
         (out *mangle-out*))
 
72
    (declare (character tem)(fixnum n))
 
73
    (cond ((> n (mangle-type special-escape))
 
74
           (vector-push tem *mangle-out*))
 
75
          ((= n (mangle-type special-escape))
 
76
           (vector-push  *mangle-escape* out)
 
77
           (vector-push  (aref *mangle-escapes* (char-code ch) )out))
 
78
          ((= n (mangle-type octal))
 
79
           (vector-push  #.(char-upcase *mangle-escape*) out)
 
80
           (let ((m (char-code ch)))
 
81
             (vector-push  (code-char
 
82
                                   (the fixnum (+ (logand (the fixnum
 
83
                                                               (ash m -6)) 7)
 
84
                                                  (char-code #\0))))
 
85
                                   out)
 
86
             (vector-push  (code-char
 
87
                                   (the fixnum (+ (logand (the fixnum
 
88
                                                               (ash m -3)) 7)
 
89
                                                  (char-code #\0))))
 
90
                                   out)
 
91
             (vector-push  (code-char
 
92
                                   (the fixnum (+ (logand  m  7)
 
93
                                                  (char-code #\0))))
 
94
                                   out)))
 
95
          (t (wfs-error)))))
 
96
 
 
97
#+how_to_unmangle ;; get next character and unmangle it.
 
98
(defun unmangle-next ()
 
99
  (let ((y (get-next)))
 
100
    (cond ((alpha-char-p y)
 
101
           (cond ((lower-case-p y) (upcase-char y))
 
102
                 ((eql y *mangle-escape*)
 
103
                  (let ((n (get-next)))
 
104
                    (cond ((digit-char-p n)
 
105
                           (make-octal-char n (get-next) (get-next)))
 
106
                          ((upper-case-p n)
 
107
                           (code-char (+ (char-code #\0) (- n (char-code #\A)))))
 
108
                          (t n))))
 
109
                 ((car (rassoc (list n)
 
110
                               '((#\+ #\Q)(#\- #\_)(#\* #\A)(#\% #\P)
 
111
                                 (#\; #\X)(#\. #\Z)(#\, #\Y)
 
112
                                 (#\e #\E)))))
 
113
                 (t (char-downcase n))))
 
114
          (t y))))
 
115
                               
 
116