40
40
;;; works based upon this Software are permitted, as long as the
41
41
;;; following conditions are met:
43
;;; o this copyright notice is included intact and is prominently
44
;;; visible in the Software
45
;;; o distribution of a modification to the Software have been
46
;;; previously submitted to the maintainers; if the maintainers
47
;;; decide not to include the submitted changes, the "full
48
;;; name" of the re-distributed Software ("MK:DEFSYSTEM", or
49
;;; "MAKE:DEFSYSTEM", or "MK-DEFSYSTEM") must be changed.
43
;;; o this copyright notice is included intact and is prominently
44
;;; visible in the Software
45
;;; o if modifications have been made to the source code of the
46
;;; this package that have not been adopted for inclusion in the
47
;;; official version of the Software as maintained by the Copyright
48
;;; holders, then the modified package MUST CLEARLY identify that
49
;;; such package is a non-standard and non-official version of
50
;;; the Software. Furthermore, it is strongly encouraged that any
51
;;; modifications made to the Software be sent via e-mail to the
52
;;; MK-DEFSYSTEM maintainers for consideration of inclusion in the
53
;;; official MK-DEFSYSTEM package.
51
55
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
52
56
;;; EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
608
612
;;; Harlequin LispWorks
609
613
;;; CLISP (CLISP3 [SPARC])
610
614
;;; Symbolics XL12000 (Genera 8.3)
615
;;; Scieneer Common Lisp (SCL) 1.1
616
;;; Macintosh Common Lisp
612
619
;;; DEFSYSTEM needs to be tested in the following lisps:
613
;;; Macintosh Common Lisp
614
621
;;; Symbolics Common Lisp (8.0)
615
622
;;; KCL (June 3, 1987 or later)
616
623
;;; AKCL (1.86, June 30, 1987 or later)
854
861
;;; Now that ANSI CL includes PROVIDE and REQUIRE again, is this code
857
#-(or (and :CMU (not :new-compiler))
864
873
(and allegro-version>= (version>= 4 1)))
865
(eval-when #-(or :lucid :cmu17 :cmu18 :gcl)
874
(eval-when #-(or :lucid :gcl)
866
875
(:compile-toplevel :load-toplevel :execute)
867
#+(or :lucid :cmu17 :cmu18 :gcl)
868
877
(compile load eval)
870
879
(unless (or (fboundp 'lisp::require)
967
976
(setf pathname nil))))
968
977
;; Now that we've got the list of pathnames, let's load them.
969
978
(dolist (pname pathname t)
970
(load pname :verbose nil)))))))
979
(load pname :verbose nil))))))
972
982
;;; ********************************
973
983
;;; Set up Package *****************
980
990
;;; MAKE package. A nice side-effect is that the short nickname
981
991
;;; MK is my initials.
984
(defpackage "MAKE" (:use "COMMON-LISP") (:nicknames "MK"))
993
#+(or clisp cormanlisp ecl (and gcl defpackage) sbcl)
987
994
(defpackage "MAKE" (:use "COMMON-LISP") (:nicknames "MK"))
990
(defpackage "MAKE" (:use "LISP") (:nicknames "MK"))
997
(defpackage "MAKE" (:use "LISP" "SYSTEM") (:nicknames "MK")
998
(:import-from conditions ignore-errors))
992
#-(or :sbcl :cltl2 :lispworks)
1000
#-(or :sbcl :cltl2 :lispworks :ecl :scl)
993
1001
(in-package "MAKE" :nicknames '("MK"))
995
1003
;;; For CLtL2 compatible lisps...
1037
1045
(defpackage "MAKE" (:use "COMMON-LISP")
1038
1046
(:nicknames "MK"))
1040
#+(or :cltl2 :lispworks)
1049
(defpackage :make (:use :common-lisp)
1052
#+(or :cltl2 :lispworks :scl)
1041
1053
(eval-when (compile load eval)
1042
1054
(in-package "MAKE"))
1044
1059
;;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu> 19970105
1045
1060
;;; 'provide' is not esternal in 'CLTL1' in Allegro v 4.1
1046
1061
#+(and :excl :allegro-v4.0 :cltl2)
1193
1211
(defun home-subdirectory (directory)
1194
1212
(concatenate 'string
1195
#+(or :sbcl :cmu) "home:"
1196
#-(or :sbcl :cmu) (let ((homedir (user-homedir-pathname)))
1197
(or (when homedir (namestring homedir))
1213
#+(or :sbcl :cmu :scl)
1215
#-(or :sbcl :cmu :scl)
1216
(let ((homedir (user-homedir-pathname)))
1217
(or (and homedir (namestring homedir))
1230
1250
#+ACLPC (current-directory)
1231
1251
#+:allegro (excl:current-directory)
1232
1252
#+:sbcl (progn *default-pathname-defaults*)
1233
#+:CMU (ext:default-directory)
1253
#+(or :cmu :scl) (ext:default-directory)
1234
1254
;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu>
1235
1255
;; Somehow it is better to qualify default-directory in CMU with
1236
1256
;; the appropriate package (i.e. "EXTENSIONS".)
1267
1287
(defun add-registry-location (pathname)
1268
1288
"Adds a path to the central registry."
1269
(push pathname *central-registry*))
1289
(pushnew pathname *central-registry* :test #'equal))
1271
1291
(defvar *bin-subdir* ".bin/"
1272
1292
"The subdirectory of an AFS directory where the binaries are really kept.")
1330
1350
(pushnew :ibm-rt-pc *features*))
1333
#+:gcl(defun compile-file-pathname (x) x)
1334
1353
;;; *filename-extensions* is a cons of the source and binary extensions.
1335
1354
(defvar *filename-extensions*
1336
1355
(car `(#+(and Symbolics Lispm) ("lisp" . "bin")
1357
1377
;; PA is Precision Architecture, HP's 9000/800 RISC cpu
1358
1378
#+(and Lucid PA) ("lisp" . "hbin")
1359
1379
#+excl ("cl" . ,(pathname-type (compile-file-pathname "foo.cl")))
1360
#+CMU ("lisp" . ,(or (c:backend-fasl-file-type c:*backend*) "fasl"))
1380
#+(or :cmu :scl) ("lisp" . ,(or (c:backend-fasl-file-type c:*backend*) "fasl"))
1361
1381
; #+(and :CMU (not (or :sgi :sparc))) ("lisp" . "fasl")
1362
1382
; #+(and :CMU :sgi) ("lisp" . "sgif")
1363
1383
; #+(and :CMU :sparc) ("lisp" . "sparcf")
1366
1386
#+TI ("lisp" . #.(string (si::local-binary-file-type)))
1367
1387
#+:gclisp ("LSP" . "F2S")
1368
1388
#+pyramid ("clisp" . "o")
1369
#+:coral ("lisp" . "pfsl")
1370
1390
;; Harlequin LispWorks
1371
1391
#+:lispworks ("lisp" . ,COMPILER:*FASL-EXTENSION-STRING*)
1372
1392
; #+(and :sun4 :lispworks) ("lisp" . "wfasl")
1373
1393
; #+(and :mips :lispworks) ("lisp" . "mfasl")
1374
#+:mcl ("lisp" . "pfsl")
1375
#+:gcl ("lsp" . "o")
1394
#+:mcl ("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp")))
1395
#+:coral ("lisp" . "fasl")
1378
1398
("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp")))))
1412
1432
;;; ********************************
1413
1433
;;; Component Operation Definition *
1414
1434
;;; ********************************
1415
;jfa (eval-when (:compile-toplevel :load-toplevel :execute)
1416
(eval-when #-(or :lucid :cmu17 :cmu18 :gcl)
1417
(:compile-toplevel :load-toplevel :execute)
1418
#+(or :lucid :cmu17 :cmu18 :gcl)
1435
(eval-when #-(or :lucid :gcl)
1436
(:compile-toplevel :load-toplevel :execute)
1420
1439
(defvar *version-dir* nil
1421
1440
"The version subdir. bound in operate-on-system.")
1422
1441
(defvar *version-replace* nil
1504
1523
"sbcl" " " (lisp-implementation-version))
1505
1524
#+cmu (concatenate 'string
1506
1525
"cmu" " " (lisp-implementation-version))
1526
#+scl (concatenate 'string
1527
"scl" " " (lisp-implementation-version))
1510
1534
#+lucid "lucid"
1511
1535
#+ACLPC "aclpc"
1512
1536
#+CLISP "clisp"
1515
1537
#+Xerox "xerox"
1516
1538
#+symbolics "symbolics"
1530
1552
#+(and :sgi :allegro-version>= (version>= 4 2))
1531
1553
(machine-version)))
1532
1554
(software (software-type-translation
1533
#-(and :sgi (or :cmu :sbcl
1555
#-(and :sgi (or :cmu :sbcl :scl
1534
1556
(and :allegro-version>= (version>= 4 2))))
1535
1557
(software-type)
1536
#+(and :sgi (or :cmu :sbcl
1558
#+(and :sgi (or :cmu :sbcl :scl
1537
1559
(and :allegro-version>= (version>= 4 2))))
1538
1560
(operating-system-version)))
1539
1561
(lisp (compiler-type-translation (compiler-version))))
1857
1879
(make-pathname :host host
1860
#-(and :cmu (not (or :cmu17 :cmu18)))
1862
#+(and :cmu (not (or :cmu17 :cmu18)))
1863
(coerce directory 'simple-vector)
1865
1884
#-(or :sbcl :MCL :clisp) rel-file
1866
1885
#+(or :sbcl :MCL :clisp) rel-name
2172
2192
:version (pathname-version pathname)))
2196
(defun new-file-type (pathname type)
2197
;; why not (make-pathname :type type :defaults pathname)?
2199
:host (pathname-host pathname :case :common)
2200
:device (pathname-device pathname :case :common)
2201
:directory (pathname-directory pathname :case :common)
2202
:name (pathname-name pathname :case :common)
2203
:type (string-upcase type)
2204
:version (pathname-version pathname :case :common)))
2176
2208
;;; ********************************
2177
2209
;;; Component Defstruct ************
2622
2654
(make-pathname :host (when (component-host component)
2623
2655
;; MCL2.0b1 and ACLPC cause an error on
2624
2656
;; (pathname-host nil)
2625
(pathname-host (component-host component)))
2626
:directory (pathname-directory pathname)
2657
(pathname-host (component-host component)
2658
#+scl :case #+scl :common
2660
:directory (pathname-directory pathname
2661
#+scl :case #+scl :common
2627
2663
;; Use :directory instead of :defaults
2628
:name (pathname-name pathname)
2629
:type (component-extension component type)
2664
:name (pathname-name pathname
2665
#+scl :case #+scl :common
2667
:type #-scl (component-extension component type)
2668
#+scl (string-upcase
2669
(component-extension component type))
2631
#+(and :CMU (not (or :cmu17 :cmu18)))
2635
#-(or :sbcl (and :CMU (not (or :cmu17 :cmu18))))
2636
2674
(let ((dev (component-device component)))
2638
(pathname-device dev)
2639
(pathname-device pathname)))
2676
(pathname-device dev
2677
#+scl :case #+scl :common
2679
(pathname-device pathname
2680
#+scl :case #+scl :common
2640
2682
;; :version :newest
2748
2790
;; Return the component.
2797
;;; 2002-11-22 Marco Antoniotti
2798
;;; Added code to achieve a first cut "pathname less" operation,
2799
;;; following the ideas in ASDF. If the DEFSYSTEM form is loaded from
2800
;;; a file, then the location of the file (intended as a directory) is
2801
;;; computed from *LOAD-PATHNAME* and stored as the :SOURCE-PATHNAME
2751
2804
(defmacro defsystem (name &rest definition-body)
2805
(unless (find :source-pathname definition-body)
2806
(setf definition-body
2807
(list* :source-pathname
2808
'(when *load-pathname*
2809
(make-pathname :name nil
2811
:defaults *load-pathname*))
2752
2813
`(create-component :defsystem ',name ',definition-body nil 0))
2754
2815
(defun create-component-pathnames (component parent)
3305
3366
(declare #-(or :cltl2 :ansi-cl) (ignore override-compilation-unit))
3306
3367
(unwind-protect
3307
3368
;; Protect the undribble.
3308
(#+(and (not :gcl) (or :cltl2 :ansi-cl)) with-compilation-unit
3309
#+(and (not :gcl) (or :cltl2 :ansi-cl)) (:override override-compilation-unit)
3310
#-(and (not :gcl) (or :cltl2 :ansi-cl)) progn
3369
(#+(and (or :cltl2 :ansi-cl) (not :gcl)) with-compilation-unit
3370
#+(and (or :cltl2 :ansi-cl) (not :gcl))
3371
(:override override-compilation-unit)
3372
#-(and (or :cltl2 :ansi-cl) (not :gcl)) progn
3311
3373
(when *reset-full-pathname-table* (clear-full-pathname-tables))
3312
3374
(when dribble (dribble dribble))
3313
3375
(when test (setq verbose t))
3323
3385
;; CL implementations may uniformly default this to nil
3324
3386
(let ((*load-verbose* #-common-lisp-controller t
3325
3387
#+common-lisp-controller nil) ; nil
3326
#-(or MCL CMU CLISP :sbcl lispworks)
3388
#-(or MCL CMU CLISP ECL :sbcl lispworks scl)
3327
3389
(*compile-file-verbose* t) ; nil
3328
3390
#+common-lisp-controller
3329
3391
(*compile-print* nil)
3345
3407
(*load-source-instead-of-binary* load-source-instead-of-binary)
3346
3408
(*minimal-load* minimal-load)
3347
3409
(system (find-system name :load)))
3348
#-(or CMU CLISP :sbcl :lispworks :cormanlisp)
3410
#-(or CMU CLISP :sbcl :lispworks :cormanlisp scl)
3349
3411
(declare (special *compile-verbose* #-MCL *compile-file-verbose*)
3350
(ignore *compile-verbose* #-MCL *compile-file-verbose*)
3351
(optimize (inhibit-warnings 3)))
3412
#-openmcl (ignore *compile-verbose*
3413
#-MCL *compile-file-verbose*)
3414
#-openmcl (optimize (inhibit-warnings 3)))
3352
3415
(unless (component-operation operation)
3353
3416
(error "Operation ~A undefined." operation))
3354
3417
(operate-on-component system operation force))))
3530
3593
(eval (component-finally-do component))))
3532
3595
;; add the banner if needed
3534
3597
(when (component-banner component)
3535
3598
(unless (stringp (component-banner component))
3536
3599
(error "The banner should be a string, it is: ~S"
3659
3722
default-action (version *version*))
3660
3723
;; If the pathname is present, this behaves like the old require.
3661
3724
(unless (and module-name
3662
(find #-CMU (string module-name)
3663
#+CMU (string-downcase (string module-name))
3725
(find (string module-name)
3664
3726
*modules* :test #'string=))
3665
3727
(cond (pathname
3666
3728
(funcall *old-require* module-name pathname))
3733
3795
;;; if anybody does a funcall on #'require.
3735
3797
;;; Redefine old require to call the new require.
3736
(eval-when #-(or :lucid :cmu17 :cmu18 :gcl) (:load-toplevel :execute)
3737
#+(or :lucid :cmu17 :cmu18 :gcl) (load eval)
3798
(eval-when #-(or :lucid :gcl) (:load-toplevel :execute)
3799
#+(or :lucid :gcl) (load eval)
3738
3800
(unless *old-require*
3739
3801
(setf *old-require*
3740
3802
(symbol-function
3743
3805
#+:sbcl 'cl:require
3744
3806
#+:lispworks3.1 'common-lisp::require
3745
3807
#+(and :lispworks (not :lispworks3.1)) 'system::require
3746
#+:mcl 'ccl:require))
3808
#+:openmcl 'cl:require
3809
#+(and :mcl (not :openmcl)) 'ccl:require
3748
3812
(unless *dont-redefine-require*
3749
3813
(let (#+(or :mcl (and :CCL (not :lispworks)))
3750
3814
(ccl:*warn-if-redefine-kernel* nil))
3751
#-(or (and allegro-version>= (version>= 4 1)) :lispworks)
3815
#-(or (and allegro-version>= (version>= 4 1)) :lispworks :sbcl)
3752
3816
(setf (symbol-function
3753
3817
#-(or (and :excl :allegro-v4.0) :mcl :sbcl :lispworks) 'lisp:require
3754
3818
#+(and :excl :allegro-v4.0) 'cltl1:require
3755
3819
#+:lispworks3.1 'common-lisp::require
3757
3820
#+(and :lispworks (not :lispworks3.1)) 'system::require
3758
#+:mcl 'ccl:require)
3821
#+:openmcl 'cl:require
3822
#+(and :mcl (not :openmcl)) 'ccl:require
3759
3824
(symbol-function 'new-require))
3761
3826
(let ((warn-packs system::*packages-for-warn-on-redefinition*))
3770
3835
#+(and allegro-version>= (version>= 4 1))
3771
3836
(excl:without-package-locks
3772
3837
(setf (symbol-function 'lisp:require)
3773
(symbol-function 'new-require))))))
3838
(symbol-function 'new-require)))
3840
(sb-ext:without-package-locks
3841
(setf (symbol-function 'cl:require)
3842
(symbol-function 'new-require)))))))
3776
3844
;;; ********************************
3777
3845
;;; Language-Dependent Characteristics
3857
3925
;;; *** PseudoScheme Language Definition
3858
3926
(defun scheme-compile-file (filename &rest args)
3859
(let ((scheme-package (find-package "SCHEME")))
3860
(apply (symbol-function (find-symbol "COMPILE-FILE"
3927
(let ((scheme-package (find-package '#:scheme)))
3928
(apply (symbol-function (find-symbol (symbol-name 'compile-file)
3863
3931
(funcall (symbol-function
3864
(find-symbol "INTERACTION-ENVIRONMENT"
3932
(find-symbol (symbol-name '#:interaction-environment)
3868
3936
(define-language :scheme
3887
3955
#+:allegro (excl:run-shell-command
3888
3956
(format nil "~A~@[ ~{~A~^ ~}~]"
3889
3957
program arguments))
3890
#+KCL (system (format nil "~A~@[ ~{~A~^ ~}~]" program arguments))
3891
#+:cmu (extensions:run-program program arguments)
3958
#+(or :kcl :ecl) (system (format nil "~A~@[ ~{~A~^ ~}~]" program arguments))
3959
#+(or :cmu :scl) (extensions:run-program program arguments)
3960
#+:openmcl (ccl:run-program program arguments)
3892
3961
#+:sbcl (sb-ext:run-program program arguments)
3893
3962
#+:lispworks (foreign:call-system-showing-output
3894
3963
(format nil "~A~@[ ~{~A~^ ~}~]" program arguments))
3943
#-cmu (declare (ignore error-file error-output))
4012
#-(or cmu scl) (declare (ignore error-file error-output))
3945
4014
(flet ((make-useable-stream (&rest streams)
3946
4015
(apply #'make-broadcast-stream (delete nil streams)))
3948
(let (#+cmu (error-file error-file)
3949
#+cmu (error-file-stream nil)
4017
(let (#+(or cmu scl) (error-file error-file)
4018
#+(or cmu scl) (error-file-stream nil)
3950
4019
(verbose-stream nil)
3951
4020
(old-timestamp (file-write-date output-file))
3952
4021
(fatal-error nil)
4072
4141
:compiler #'c-compile-file
4073
4142
:loader #+:lucid #'load-foreign-files
4074
4143
#+:allegro #'load
4075
#+:cmu #'alien:load-foreign
4144
#+(or :cmu :scl) #'alien:load-foreign
4076
4145
#+:sbcl #'sb-alien:load-foreign
4077
4146
#+(and :lispworks :unix (not :linux)) #'link-load:read-foreign-modules
4078
4147
#+(and :lispworks (or (not :unix) :linux)) #'fli:register-module
4188
4258
#+gcl :system-p #+gcl t
4190
#+CMU (and *cmu-errors-to-file*
4191
(component-full-pathname component
4193
#+(and CMU (not :new-compiler))
4195
#+(and CMU (not :new-compiler))
4259
#+(or :cmu :scl) :error-file
4260
#+(or :cmu :scl) (and *cmu-errors-to-file*
4261
(component-full-pathname component
4196
4266
*cmu-errors-to-terminal*
4197
4267
(component-compiler-options component)
added
removed
lisp-utils/defsystem.lisp
