/[slime]/slime/swank-sbcl.lisp
ViewVC logotype

Diff of /slime/swank-sbcl.lisp

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

revision 1.267 by trittweiler, Mon Feb 22 21:38:46 2010 UTC revision 1.268 by sboukarev, Tue Mar 2 12:38:07 2010 UTC
# Line 558  compiler state." Line 558  compiler state."
558    
559  (defvar *trap-load-time-warnings* nil)  (defvar *trap-load-time-warnings* nil)
560    
561    (defun compiler-policy (qualities)
562      "Return compiler policy qualities present in the QUALITIES alist.
563    QUALITIES is an alist with (quality . value)"
564      #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
565      (loop with policy = (sb-ext:restrict-compiler-policy)
566            for (quality) in qualities
567            collect (cons quality
568                          (or (cdr (assoc quality policy))
569                              0))))
570    
571    (defun (setf compiler-policy) (policy)
572      (declare (ignorable policy))
573      #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
574      (loop for (qual . value) in policy
575            do (sb-ext:restrict-compiler-policy qual value)))
576    
577    (defmacro with-compiler-policy (policy &body body)
578      (let ((current-policy (gensym)))
579        `(let ((,current-policy (compiler-policy ,policy)))
580           (setf (compiler-policy) ,policy)
581           (unwind-protect (progn ,@body)
582             (setf (compiler-policy) ,current-policy)))))
583    
584  (defimplementation swank-compile-file (input-file output-file  (defimplementation swank-compile-file (input-file output-file
585                                         load-p external-format)                                         load-p external-format
586                                           &key policy)
587    (multiple-value-bind (output-file warnings-p failure-p)    (multiple-value-bind (output-file warnings-p failure-p)
588        (with-compilation-hooks ()        (with-compiler-policy policy
589          (compile-file input-file :output-file output-file          (with-compilation-hooks ()
590                        :external-format external-format))            (compile-file input-file :output-file output-file
591                            :external-format external-format)))
592      (values output-file warnings-p      (values output-file warnings-p
593              (or failure-p              (or failure-p
594                  (when load-p                  (when load-p
# Line 593  compiler state." Line 618  compiler state."
618    "Return a temporary file name to compile strings into."    "Return a temporary file name to compile strings into."
619    (tempnam nil nil))    (tempnam nil nil))
620    
 (defun get-compiler-policy (default-policy)  
   (declare (ignorable default-policy))  
   #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)  
   (remove-duplicates (append default-policy (sb-ext:restrict-compiler-policy))  
                      :key #'car))  
   
 (defun set-compiler-policy (policy)  
   (declare (ignorable policy))  
   #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)  
    (loop for (qual . value) in policy  
          do (sb-ext:restrict-compiler-policy qual value)))  
   
621  (defimplementation swank-compile-string (string &key buffer position filename  (defimplementation swank-compile-string (string &key buffer position filename
622                                           policy)                                           policy)
623    (let ((*buffer-name* buffer)    (let ((*buffer-name* buffer)
624          (*buffer-offset* position)          (*buffer-offset* position)
625          (*buffer-substring* string)          (*buffer-substring* string)
626          (temp-file-name (temp-file-name))          (temp-file-name (temp-file-name)))
         (saved-policy (get-compiler-policy '((debug . 0) (speed . 0)))))  
     (when policy  
       (set-compiler-policy policy))  
627      (flet ((load-it (filename)      (flet ((load-it (filename)
628               (when filename (load filename)))               (when filename (load filename)))
629             (compile-it (cont)             (compile-it (cont)
# Line 631  compiler state." Line 641  compiler state."
641        (with-open-file (s temp-file-name :direction :output :if-exists :error)        (with-open-file (s temp-file-name :direction :output :if-exists :error)
642          (write-string string s))          (write-string string s))
643        (unwind-protect        (unwind-protect
644             (if *trap-load-time-warnings*             (with-compiler-policy policy
645                 (compile-it #'load-it)              (if *trap-load-time-warnings*
646                 (load-it (compile-it #'identity)))                  (compile-it #'load-it)
647                    (load-it (compile-it #'identity))))
648          (ignore-errors          (ignore-errors
           (set-compiler-policy saved-policy)  
649            (delete-file temp-file-name)            (delete-file temp-file-name)
650            (delete-file (compile-file-pathname temp-file-name)))))))            (delete-file (compile-file-pathname temp-file-name)))))))
651    

Legend:
Removed from v.1.267  
changed lines
  Added in v.1.268

  ViewVC Help
Powered by ViewVC 1.1.5