Changeset 15483
- Timestamp:
- 11/11/20 17:58:12 (2 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
r15398 r15483 33 33 34 34 (require "COMPILER-PASS2") 35 36 35 37 36 (export 'compile-file-if-needed) … … 224 223 *compile-file-environment*)))))) 225 224 226 227 225 (declaim (ftype (function (t stream t) t) process-progn)) 228 226 (defun process-progn (forms stream compile-time-too) … … 230 228 (process-toplevel-form form stream compile-time-too)) 231 229 nil) 232 233 230 234 231 (declaim (ftype (function (t t t) t) process-toplevel-form)) … … 240 237 (eval form)) 241 238 form)) 242 243 244 239 245 240 (defun process-toplevel-macrolet (form stream compile-time-too) … … 279 274 :initial-contents ',(coerce initial-value 'list))))) 280 275 `(progn 281 (put ',(second form) 'sys::source (cons '(,(second form) ,(namestring *source*) ,*source-position*) (get ',(second form) 'sys::source nil))) 276 (sys:put ',(second form) 'sys::source 277 (cl:cons '(,(second form) ,(namestring *source*) ,*source-position*) 278 (cl:get ',(second form) 'sys::source nil))) 282 279 ,form)) 283 280 … … 322 319 (when (quoted-form-p type) (setq type (second type))) 323 320 (let ((sym (if (consp name) (second name) name))) 324 `(put ',sym 'sys::source (cons '(,type ,(namestring *source*) ,*source-position*) 325 (get ',sym 'sys::source nil)))))) 321 `(sys:put ',sym 'sys::source 322 (cl:cons '(,type ,(namestring *source*) ,*source-position*) 323 (cl:get ',sym 'sys::source nil)))))) 326 324 327 325 … … 358 356 ;; FIXME This should be a warning or error of some sort... 359 357 (format *error-output* "; Unable to compile method~%")))))))))) 360 361 362 358 (when compile-time-too 363 359 (let* ((copy-form (copy-tree form)) … … 398 394 :initial-contents ',(coerce initial-value 'list)))) 399 395 `(progn 400 (put ',name 'sys::source (cons (list :variable ,(namestring *source*) ,*source-position*) (get ',name 'sys::source nil))) 396 (sys:put ',name 'sys::source 397 (cl:cons 398 (list :variable ,(namestring *source*) ,*source-position*) 399 (cl:get ',name 'sys::source nil))) 401 400 ,form))) 402 401 … … 413 412 (let ((*package* +keyword-package+)) 414 413 (output-form form)) 415 ;; a bit ugly here. Since we precompile, and added record-source-information we need to know where it is. 416 ;; The defpackage is at top, so we know where the name is (though it is a string by now) 417 ;; (if it is a defpackage) 414 ;; a bit ugly here. Since we precompile, and added 415 ;; record-source-information we need to know where it is. 416 417 ;; The defpackage is at top, so we know where the name is (though 418 ;; it is a string by now) (if it is a defpackage) 418 419 (if defpackage-name 419 `( put ,defpackage-name 'sys::source420 (cons '(:package ,(namestring *source*) ,*source-position*)421 (get ,defpackage-name 'sys::source nil)))420 `(sys:put ,defpackage-name 'sys::source 421 (cl:cons '(:package ,(namestring *source*) ,*source-position*) 422 (cl:get ,defpackage-name 'sys::source nil))) 422 423 nil))) 423 424 … … 439 440 (eval form) 440 441 `(progn 441 (put ',(second form) 'sys::source (cons '(,(second form) ,(namestring *source*) ,*source-position*) (get ',(second form) 'sys::source nil))) 442 (sys:put ',(second form) 'sys::source 443 (cl:cons '(,(second form) ,(namestring *source*) ,*source-position*) 444 (cl:get ',(second form) 'sys::source nil))) 442 445 ,form)) 443 446 … … 487 490 (when (eq (car form) 'defgeneric) 488 491 `(progn 489 (put ',sym 'sys::source 490 (cons '((:generic-function ,(second form)) ,(namestring *source*) ,*source-position*) (get ',sym 'sys::source nil))) 492 (sys:put ',sym 'sys::source 493 (cl:cons '((:generic-function ,(second form)) 494 ,(namestring *source*) ,*source-position*) 495 (cl:get ',sym 'sys::source nil))) 491 496 ,@(loop for method-form in (cdddr form) 492 497 when (eq (car method-form) :method) … … 495 500 (mop::parse-defmethod `(,(second form) ,@(rest method-form))) 496 501 ;;; FIXME: style points for refactoring double backquote to "normal" form 497 `(put ',sym 'sys::source 498 (cons `((:method ,',sym ,',qualifiers ,',specializers) ,,(namestring *source*) ,,*source-position*) 499 (get ',sym 'sys::source nil))))))))) 502 `(sys:put ',sym 'sys::source 503 (cl:cons `((:method ,',sym ,',qualifiers ,',specializers) 504 ,,(namestring *source*) ,,*source-position*) 505 (cl:get ',sym 'sys::source nil))))))))) 500 506 501 507 … … 538 544 539 545 (if (special-operator-p name) 540 `( put ',name 'macroexpand-macro541 ( make-macro ',name542 (sys::get-fasl-function *fasl-loader*543 ,saved-class-number)))546 `(sys:put ',name 'macroexpand-macro 547 (sys:make-macro ',name 548 (sys::get-fasl-function *fasl-loader* 549 ,saved-class-number))) 544 550 `(progn 545 (put ',name 'sys::source 546 (cons '(:macro ,(namestring *source*) ,*source-position*) (get ',name 'sys::source nil))) 547 (fset ',name 548 (make-macro ',name 549 (sys::get-fasl-function *fasl-loader* 550 ,saved-class-number)) 551 ,*source-position* 552 ',(third form) 553 ,(%documentation name 'cl:function))))))) 551 (sys:put ',name 'sys::source 552 (cl:cons '(:macro ,(namestring *source*) ,*source-position*) 553 (cl:get ',name 'sys::source nil))) 554 (sys:fset ',name 555 (sys:make-macro ',name 556 (sys::get-fasl-function *fasl-loader* 557 ,saved-class-number)) 558 ,*source-position* 559 ',(third form) 560 ,(%documentation name 'cl:function))))))) 554 561 555 562 (declaim (ftype (function (t t t) t) process-toplevel-defun)) … … 594 601 (setf form 595 602 `(progn 596 (put ',sym 'sys::source (cons '((:function ,name) ,(namestring *source*) ,*source-position*) (get ',sym 'sys::source nil))) 597 (fset ',name 598 (sys::get-fasl-function *fasl-loader* 599 ,saved-class-number) 600 ,*source-position* 601 ',lambda-list 602 ,doc))))) 603 (sys:put ',sym 'sys::source 604 (cl:cons '((:function ,name) 605 ,(namestring *source*) ,*source-position*) 606 (cl:get ',sym 'sys::source nil))) 607 (sys:fset ',name 608 (sys::get-fasl-function *fasl-loader* 609 ,saved-class-number) 610 ,*source-position* 611 ',lambda-list 612 ,doc))))) 603 613 (t 604 614 (compiler-warn "Unable to compile function ~A. Using interpreted form instead.~%" name) … … 611 621 *compile-file-environment*))) 612 622 (setf form 613 `( fset ',name614 ,precompiled-function615 ,*source-position*616 ',lambda-list617 ,doc)))623 `(sys:fset ',name 624 ,precompiled-function 625 ,*source-position* 626 ',lambda-list 627 ,doc))) 618 628 (when compile-time-too 619 629 (eval form))))) … … 624 634 lambda-list 625 635 (append decls body))) 626 (output-form `( setf (inline-expansion ',name)627 ',(inline-expansion name))))))636 (output-form `(cl:setf (inline-expansion ',name) 637 ',(inline-expansion name)))))) 628 638 (push name jvm::*functions-defined-in-current-file*) 629 639 (note-name-defined name) 630 640 (push name *toplevel-functions*) 631 641 (when (and (consp name) 632 (eq 'setf (first name))) 642 (or 643 (eq 'setf (first name)) 644 (eq 'cl:setf (first name)))) 633 645 (push (second name) *toplevel-setf-functions*)) 634 646 ;; If NAME is not fbound, provide a dummy definition so that … … 688 700 (when (and (symbolp operator) 689 701 (macro-function operator *compile-file-environment*)) 690 (when (eq operator 'define-setf-expander) ;; ??? what if the symbol is package qualified?702 (when (eq operator 'define-setf-expander) 691 703 (push (second form) *toplevel-setf-expanders*)) 692 (when (and (eq operator 'defsetf) ;; ??? what if the symbol is package qualified?704 (when (and (eq operator 'defsetf) 693 705 (consp (third form))) ;; long form of DEFSETF 694 706 (push (second form) *toplevel-setf-expanders*)) … … 770 782 (rename-file zipfile output-file))) 771 783 772 (defun write-fasl-prologue (stream) 773 (let ((out stream)) 784 (defun write-fasl-prologue (stream in-package) 785 "Write the forms that form the fasl to STREAM. 786 787 The last form will use IN-PACKAGE to set the *package* to its value when 788 COMPILE-FILE was invoked." 789 (let ((out stream) 790 (*package* (find-package :keyword))) 774 791 ;; write header 775 792 (write "; -*- Mode: Lisp -*-" :escape nil :stream out) 776 793 (%stream-terpri out) 777 (write (list ' init-fasl :version *fasl-version*) :stream out)794 (write (list 'sys:init-fasl :version *fasl-version*) :stream out) 778 795 (%stream-terpri out) 779 (write (list ' setq '*source* *compile-file-truename*) :stream out)796 (write (list 'cl:setq 'sys:*source* *compile-file-truename*) :stream out) 780 797 (%stream-terpri out) 781 798 … … 783 800 ;; because the list of uninterned symbols has been fixed now. 784 801 (when *fasl-uninterned-symbols* 785 (write (list ' setq '*fasl-uninterned-symbols*802 (write (list 'cl:setq 'sys::*fasl-uninterned-symbols* 786 803 (coerce (mapcar #'car (nreverse *fasl-uninterned-symbols*)) 787 804 'vector)) … … 790 807 791 808 (when (> *class-number* 0) 792 (write (list ' setq '*fasl-loader*809 (write (list 'cl:setq 'sys:*fasl-loader* 793 810 `(sys::make-fasl-class-loader 794 811 ,(concatenate 'string "org.armedbear.lisp." 795 812 (base-classname)))) 796 813 :stream out)) 814 (%stream-terpri out) 815 816 (write `(in-package ,(package-name in-package)) 817 :stream out) 797 818 (%stream-terpri out))) 798 799 800 819 801 820 (defvar *binary-fasls* nil) … … 817 836 *fasl-uninterned-symbols* 818 837 (warnings-p nil) 838 (in-package *package*) 819 839 (failure-p nil)) 820 840 (when *compile-verbose* … … 933 953 :if-exists :supersede 934 954 :external-format *fasl-external-format*) 935 (let ((*package* (find-package '#:cl))955 (let ((*package* (find-package :keyword)) 936 956 (*print-fasl* t) 937 957 (*print-array* t) … … 966 986 ;; (*readtable* (copy-readtable nil)) 967 987 968 (write-fasl-prologue out )988 (write-fasl-prologue out in-package) 969 989 ;; copy remaining content 970 990 (loop for line = (read-line in nil :eof)
Note: See TracChangeset
for help on using the changeset viewer.
