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

Diff of /gcl/cmpnew/cmpmain.lsp

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

revision 1.17 by camm, Mon Nov 11 03:43:06 2002 UTC revision 1.18 by camm, Wed Feb 26 22:21:35 2003 UTC
# Line 86  Line 86 
86  (defvar *default-c-file* nil)  (defvar *default-c-file* nil)
87  (defvar *default-h-file* nil)  (defvar *default-h-file* nil)
88  (defvar *default-data-file* nil)  (defvar *default-data-file* nil)
89    (defvar *keep-gaz* nil)
90    
91  ;;  (list section-length split-file-names next-section-start-file-position)  ;;  (list section-length split-file-names next-section-start-file-position)
92  ;;  Many c compilers cannot handle the large C files resulting from large lisp files.  ;;  Many c compilers cannot handle the large C files resulting from large lisp files.
# Line 138  Line 139 
139                  (setq args (append args (list :output-file (car args)))))                  (setq args (append args (list :output-file (car args)))))
140              (return              (return
141               (prog1 (apply 'compile-file gaz (cdr args))               (prog1 (apply 'compile-file gaz (cdr args))
142                 (delete-file gaz)))                 (unless *keep-gaz* (delete-file gaz))))
143              ))              ))
144           (t nil))           (t nil))
145     (if (consp *split-files*)     (if (consp *split-files*)
# Line 395  Cannot compile ~a.~%" Line 396  Cannot compile ~a.~%"
396    
397    
398  (defun compile (name &optional def &aux tem gaz (*default-pathname-defaults* #"."))  (defun compile (name &optional def &aux tem gaz (*default-pathname-defaults* #"."))
399    
400    (cond ((not(symbolp name)) (error "Must be a name"))    (cond ((not(symbolp name)) (error "Must be a name"))
401          ((and (consp def)          ((and (consp def)
402                (member (car def) '(lambda )))                (member (car def) '(lambda )))
# Line 403  Cannot compile ~a.~%" Line 405  Cannot compile ~a.~%"
405                 def)                 def)
406           (compile name))           (compile name))
407          (def (error "def not a lambda expression"))          (def (error "def not a lambda expression"))
408          ((setq tem(macro-function name))          ((setq tem (macro-function name))
409           (setf (symbol-function 'cmp-anon) tem)           (setf (symbol-function 'cmp-anon) tem)
410           (compile 'cmp-anon)           (compile 'cmp-anon)
411           (setf (macro-function name) (macro-function name))           (setf (macro-function name) (macro-function name))
# Line 411  Cannot compile ~a.~%" Line 413  Cannot compile ~a.~%"
413          ((and (setq tem (symbol-function name))          ((and (setq tem (symbol-function name))
414                (consp tem))                (consp tem))
415           (let ((na (if (symbol-package name) name 'cmp-anon)))           (let ((na (if (symbol-package name) name 'cmp-anon)))
416             (with-open-file             (unless (and (fboundp 'si::init-cmp-anon) (or (si::init-cmp-anon) (fmakunbound 'si::init-cmp-anon)))
417                 (st (setq gaz (gazonk-name)) :direction :output)               (with-open-file
418               (prin1-cmp `(defun ,na ,@ (ecase (car tem)                (st (setq gaz (gazonk-name)) :direction :output)
419                                           (lambda (cdr tem))                (prin1-cmp `(defun ,na ,@ (ecase (car tem)
420                                           (lambda-block (cddr tem))                                                 (lambda (cdr tem))
421                                           ))       st))                                                 (lambda-block (cddr tem))
422             (let ((fi (compile-file gaz)))                                                 ))       st))
423               (load fi)               (let ((fi (compile-file gaz)))
424               (delete-file fi)                 (load fi)
425               (delete-file gaz)                 (delete-file fi))
426               (or (eq na name) (setf (symbol-function name) (symbol-function na)))               (unless *keep-gaz* (delete-file gaz)))
427               (symbol-function name)             (or (eq na name) (setf (symbol-function name) (symbol-function na)))
428               )))             (symbol-function name)
429               ))
430          (t (error "can't compile ~a" name))))          (t (error "can't compile ~a" name))))
431    
432  (defun disassemble (name &aux tem)  (defun disassemble (name &aux tem)
# Line 467  Cannot compile ~a.~%" Line 470  Cannot compile ~a.~%"
470             (delete-file dn)             (delete-file dn)
471             (delete-file hn)             (delete-file hn)
472             (delete-file on)             (delete-file on)
473             (delete-file gaz))))             (unless *keep-gaz* (delete-file gaz)))))
474          (t (error "can't disassemble ~a" name))))          (t (error "can't disassemble ~a" name))))
475                    
476    

Legend:
Removed from v.1.17  
changed lines
  Added in v.1.18

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