/[gcl]/gcl/cmpnew/gcl_cmptop.lsp
ViewVC logotype

Diff of /gcl/cmpnew/gcl_cmptop.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1.2.4.6.2.4.1 by camm, Fri May 6 17:12:46 2005 UTC revision 1.1.2.4.6.2.4.2 by camm, Fri May 6 21:56:55 2005 UTC
# Line 203  Line 203 
203    (let ((new (copy-seq str)))    (let ((new (copy-seq str)))
204      (dash-to-underscore-int new 0 (length new))))      (dash-to-underscore-int new 0 (length new))))
205    
206    (defun init-name (p &optional sp (gp t) (dc t) (nt t))
207    
208      (cond ((not sp) "code")
209            ((not (pathnamep p)) (init-name (pathname p) sp gp dc nt))
210            ((not (string= (pathname-type p) "o"))
211             (init-name (merge-pathnames (make-pathname :type "o") p) sp gp dc nt))
212            #-aosvs(dc (string-downcase (init-name p sp gp nil nt)))
213            (gp (init-name (truename p) sp nil dc nt))
214            ((and nt
215                  (let* ((pn (pathname-name p))
216                         (pp (make-pathname :name pn)))
217                    (and (not (equal pp p))
218                         (eql 4 (string<= "gcl_" pn))
219                         (init-name pp sp gp dc nil)))))
220            ((dash-to-underscore (namestring p)))))
221    
222  ;; FIXME consider making this a macro  ;; FIXME consider making this a macro
223  (defun c-function-name (prefix num fname)  (defun c-function-name (prefix num fname)
224    (let ((fname (string fname)))    #-gprof(declare (ignore fname))
225      (si::string-concatenate    (si::string-concatenate
226       (string prefix)     (string prefix)
227       (write-to-string num)     (write-to-string num)
228       #+gprof(si::string-concatenate     #+gprof(let ((fname (string fname)))
229                (si::string-concatenate
230               "__"               "__"
231               (dash-to-underscore fname)               (dash-to-underscore fname)
232               "__"               "__"
233               (if *compiler-input*               (if (boundp '*compiler-input*)
234                   (dash-to-underscore (namestring *compiler-input*))                   (subseq (init-name *compiler-input* t) 4)
235                 "")))))                 "")))))
236    
237  (defun t1expr (form &aux (*current-form* form) (*first-error* t))  (defun t1expr (form &aux (*current-form* form) (*first-error* t))

Legend:
Removed from v.1.1.2.4.6.2.4.1  
changed lines
  Added in v.1.1.2.4.6.2.4.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26