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

(format nil " -w ;ar x /lib/libc.a fsavres.o ; ar qc XXXfsave fsavres.o ; echo init_~a > XXexp ; mv ~a XXX~a ; ld -r -D-1 -bexport:XXexp -bgc XXX~a -o ~a XXXfsave ; rm -f XXX~a XXexp XXXfsave fsavres.o"

585

*init-name*

586

(setq na (namestring (get-output-pathname na "o" nil)))

587

na na na na na)

588

#+(or dlopen irix5)

589

(if (not system-p)

590

(format nil

591

" -w ; mv ~a XX~a ; ld ~a -shared XX~a -o ~a -lc ; rm -f XX~a"

592

(setq na (namestring (get-output-pathname na "o" nil))) na

593

#+ignore-unresolved "-ignore_unresolved"

594

#+expect-unresolved "-expect_unresolved '*'"

595

na na na))

596

597

#+bsd ""

598

; #+bsd "-w"

599

#-(or aix3 bsd irix3) " 2> /dev/null ")

600

601

602

)

603

)

604

)

605

606

; Windows short form paths may contain tilde (~) which conflicts with

607

; format directives.

608

#+winnt (defun prep-win-path-acc ( s acc)

609

(let ((pos (search "\~" s)))

610

(if pos

611

(let ((start (subseq s 0 (1+ pos)))

612

(finish (subseq s (1+ pos))))

613

(prep-win-path-acc finish (concatenate 'string acc start "~")))

614

(concatenate 'string acc s))))

615

#+winnt (defun prep-win-path ( s ) (prep-win-path-acc s ""))

616

617

(defun compiler-cc (c-pathname o-pathname )

618

(safe-system

619

(format

620

nil

621

(prog1

622

#+irix5 (compiler-command c-pathname o-pathname )

623

#+vax "~a ~@[~*-O ~]-S -I. -w ~a ; as -J -W -o ~A ~A"

624

#+(or system-v e15 dgux sgi ) "~a ~@[~*-O ~]-c -I. ~a 2> /dev/null"

625

#+winnt (prep-win-path (compiler-command c-pathname o-pathname ))

626

#-winnt (compiler-command c-pathname o-pathname)

627

)

628

*cc*

629

(if (or (= *speed* 2) (= *speed* 3)) t nil)

630

(namestring c-pathname)

631

(namestring o-pathname)

632

633

))

634

635

#+dont_need

636

(let ((cname (pathname-name c-pathname))

637

(odir (pathname-directory o-pathname))

638

(oname (pathname-name o-pathname)))

639

(unless (and (equalp (truename "./")

640

(truename (make-pathname :directory odir)))

641

(equal cname oname))

642

(rename-file (make-pathname :name cname :type "o")

643

o-pathname)

644

)))

645

646

647

(defun compiler-build (o-pathname data-pathname)

648

#+(and system-v (not e15))

649

(safe-system (format nil "echo \"\\000\\000\\000\\000\" >> ~A"

650

(namestring o-pathname)))

651

#+(or hp-ux sun sgi)

652

(with-open-file (o-file

653

(namestring o-pathname)

654

:direction :output

655

:if-exists :append)

656

; we could do a safe-system, but forking is slow on the Iris

657

#+(or hp-ux (and sgi (not irix5)))

658

(dotimes (i 12)

659

(write-char #\^@ o-file))

660

#+sun ; we could do a safe-system, but forking is slow on the Iris

661

(dolist (v '(0 0 4 16 0 0 0 0))

662

(write-byte v o-file))

663

664

)

665

#-ld-not-accept-data

666

(when (probe-file o-pathname)

667

(nconc-files o-pathname data-pathname)

668

#+never

669

(safe-system (format nil

670

"cat ~a >> ~A"

671

(namestring data-pathname)

672

(namestring o-pathname)))))

673

674

(defun print-compiler-info ()

675

(format t "~&OPTIMIZE levels: Safety=~d~:[ (No runtime error checking)~;~], Space=~d, Speed=~d~%"

676

(cond ((null *compiler-check-args*) 0)

677

((null *safe-compile*) 1)

678

((null *compiler-push-events*) 2)

679

(t 3))

680

*safe-compile* *space* *speed*))

681

682

(defun nconc-files (a b)

683

(let* ((n 256)

684

(tem (make-string n))

685

(m 0))

686

(with-open-file (st-a a :direction :output :if-exists :append)

687

(with-open-file (st-b b )

688

(sloop::sloop

689

do (setq m (si::fread tem 0 n st-b))

690

while (and m (> m 0))

691

do (si::fwrite tem 0 m st-a))))))

692

693

#+dos

694

(progn

695

(defun directory (x &aux ans)

696

(let* ((pa (pathname x))

697

(temp "XXDIR")

698

tem

699

(name (pathname-name pa)))

700

(setq pa (make-pathname :directory (pathname-directory pa)

701

:name (or (pathname-name pa) :wild)

702

:type (pathname-type pa)))

703

(setq name (namestring pa))

704

(system (format nil "ls -d ~a > ~a" name temp))

705

(with-open-file (st temp)

706

(loop (setq tem (read-line st nil nil))

707

(if (and tem (setq tem (probe-file tem)))

708

(push tem ans) (return))))

709

ans))

710

711

(defvar *old-compile-file* #'compile-file)

712

(defun compile-file (f &rest l)

713

(let* ((p (pathname f)) dir pwd)

714

(setq dir (pathname-directory p))

715

(when dir

716

(setq dir (namestring (make-pathname :directory dir

717

:name ".")))

718

(setq pwd (namestring (truename ".")))

719

)

720

(unwind-protect

721

(progn (if dir (si::chdir dir))

722

(apply *old-compile-file* f l))

723

(if pwd (si::chdir pwd)))))

724

725

(defun user-homedir-pathname ()

726

(or (si::getenv "HOME") "/"))

727

728

)

729

730

;

731

; These functions are added to build custom images requiring

732

; the loading of binary objects on systems relocating with dlopen.

733

;

734

735

(defun make-user-init (files outn &aux tem)

736

737

(let* ((c (pathname outn))

738

(c (merge-pathnames c (make-pathname :directory '(:current))))

739

(o (merge-pathnames (make-pathname :type "o") c))

740

(c (merge-pathnames (make-pathname :type "c") c)))

741

742

(with-open-file (st c :direction :output)

743

(format st "#include <string.h>~%")

744

(format st "#include ~a~%~%" *cmpinclude*)

745

746

(format st "#define load2(a) do {")

747

(format st "printf(\"Loading %s...\\n\",(a));")

748

(format st "load(a);")

749

(format st "printf(\"Finished %s...\\n\",(a));} while(0)~%~%")

750

751

(let ((p nil))

752

(dolist (tem files)

753

(when (equal (pathname-type tem) "o")

754

(push (list

755

(substitute #\_ #\- (pathname-name tem))

756

(namestring tem))

757

p)))

758

759

(setq p (nreverse p))

760

761

(dolist (tem p)

762

(format st "extern void init_~a(void);~%" (car tem)))

763

(format st "~%")

764

765

(format st "typedef struct {void (*fn)(void);char *s;} Fnlst;~%")

766

(format st "#define NF ~a~%" (length p))

767

(format st "static Fnlst my_fnlst[NF]={")

768

(dolist (tem p)

769

(when (not (eq tem (car p)))

770

(format st ",~%"))

771

(format st "{init_~a,\"~a\"}" (car tem) (cadr tem)))

772

(format st "};~%~%")

773

774

(format st "object user_init(void) {~%")

775

(dolist (tem files)

776

(let ((tem (namestring tem)))

777

(cond ((equal (cadr (car p)) tem)

778

(format st "gcl_init_or_load1(init_~a,\"~a\");~%"

779

(car (car p)) tem)

780

(setq p (cdr p)))

781

782

(format st "load2(\"~a\");~%" tem)))))

783

(format st "return Cnil;}~%~%")

784

785

(format st "int user_match(const char *s,int n) {~%")

786

(format st " const Fnlst *f;~%")

787

(format st " for (f=my_fnlst;f<my_fnlst+NF;f++){~%")

788

(format st " if (!strncmp(s,f->s,n)) {~%")

789

(format st " gcl_init_or_load1(f->fn,f->s);~%")

790

(format st " return 1;~%")

791

(format st " }~%")

792

(format st " }~%")

793

(format st " return 0;~%")

794

(format st "}~%~%")))

795

796

(compiler-cc c o)

797

; (system (format nil "~a ~a" *cc* tem))

798

(delete-file c)

799

800

o))

801

802

(defun mysub (str it new)

803

(let ((x (search it str)))

804

(unless x

805

(return-from mysub str))

806

(let ((y (+ (length it) (the fixnum x))))

807

(declare (fixnum y))

808

(concatenate (type-of str)

809

(subseq str 0 x)

810

new

811

(mysub (subseq str y) it new)))))

812

813

(defun link (files image &optional post extra-libs (run-user-init t) &aux raw init)

814

815

(let* ((ui (make-user-init files "user-init"))

816

(raw (pathname image))

817

(init (merge-pathnames (make-pathname

818

:name (concatenate 'string "init_" (pathname-name raw))

819

:type "lsp") raw))

820

(raw (merge-pathnames raw (make-pathname :directory (list :current))))

821

(raw (merge-pathnames (make-pathname

822

:name (concatenate 'string "raw_" (pathname-name raw)))

823

raw))

824

(map (merge-pathnames (make-pathname

825

:name (concatenate 'string (pathname-name raw) "_map")) raw))

826

#+winnt (raw (merge-pathnames (make-pathname :type "exe") raw))

827

)

828

829

(with-open-file (st (namestring map) :direction :output))

830

(system

831

(format nil "~a ~a ~a ~a -L~a ~a ~a ~a"

832

*ld*

833

(namestring raw)

834

(namestring ui)

835

(let ((sfiles ""))

836

(dolist (tem files)

837

(if (equal (pathname-type tem) "o")

838

(setq sfiles (concatenate 'string sfiles " " (namestring tem)))))

839

sfiles)

840

si::*system-directory*

841

#+gnu-ld (format nil "-Wl,-Map ~a" (namestring map))

842

(let* ((par (namestring (make-pathname :directory '(:parent))))

843

(i (concatenate 'string " " par))

844

(j (concatenate 'string " " si::*system-directory* par)))

845

(mysub *ld-libs* i j))

846

(if (stringp extra-libs) extra-libs "")))

847

848

(delete-file ui)

849

850

(with-open-file (st init :direction :output)

851

(unless run-user-init

852

(format st "(fmakunbound 'si::user-init)~%"))

853

(format st "(setq si::*no-init* '(")

854

(dolist (tem files)

855

(format st " \"~a\"" (pathname-name tem)))

856

(format st "))~%")

857

(with-open-file (st1

858

(format nil "~a~a" si::*system-directory* *init-lsp*))

859

(si::copy-stream st1 st))

860

(if (stringp post) (format st "~a~%" post))

861

(format st "(si::save-system \"~a\")~%" (namestring image)))

862

863

(system (format nil "~a ~a < ~a"

864

(namestring raw)

865

si::*system-directory*

866

(namestring init)))

867

868

(delete-file raw)

869

(delete-file init))

870

871

image)

Older »