;;; -*- Mode: Common-Lisp -*- (in-package :mk) ;;; This file is used to customize the Common Lisp defsystem and the logical ;;; pathname package for our uses of it with QSIM at UT. It is designed to ;;; contain ALL additional code which is needed or patches to other code. ;;; Using this file will simplify getting updates to the Common Lisp ;;; defsystem. ;;; BKay 2 Sep 96 ;;; Fixed function append-logical-directories-mk. See note below. ;;; RSM 1 Mar 97 ;;; Deleted portions of file no longer needed for use with defsystem 3.0. ;;; Deleted package name mk:: from symbols -- unnecessary. ;;; Cleaned up and slimmed to 80 columns. ;;; Fixed function component-full-pathname-i. ;;; RSM 15 May 98 ;;; Allegro 4.3.1 has :ALLEGRO-V4.3.1 but not :ALLEGRO-V4.3 in *FEATURES*. ;;; Updated Allegro-dependent code below accordingly. ;;; BR 2 Nov 98 ;;; Updated Allegro-dependent code for V5.0 (defvar user::*qsim-root* "/u/qr" "Root directory for Qsim files") ; FOR INSTALLATION, CHANGE THIS VARIABLE. (defun add-central-registry (dir) (when (atom *central-registry*) (setq *central-registry* (list *central-registry*))) (pushnew dir *central-registry*)) (add-central-registry (format nil "~a/sys-site/" user::*qsim-root*)) ;; Stops the defsystem from querying the user (setq *bother-user-if-no-binary* nil) (setf *load-source-if-no-binary* t) (eval-when (eval compile load) (progn (machine-type-translation "SPARC" "sparc") (machine-type-translation "sun4c" "sparc") (machine-type-translation "sun4m" "sparc") ;; For the allegro at NASA-Ames; others? BKay 13Nov91: #+:allegro-v4.0 (machine-type-translation "Sun4" "sun4") (machine-type-translation "IBM RS/6000" "ibm") (machine-type-translation "DECstation 3100" "mips") ; was "DEC3100" (machine-type-translation "DEC ALPHA" "alpha") (software-type-translation "SunOS" #+:allegro-v4.2 "allegro4.2" #+:allegro-v4.3 "allegro4.3" #+:allegro-v4.3.1 "allegro4.3.1" #+:allegro-v5.0 "allegro5.0" #+(and lucid solaris) "lucid-solaris" #+(and allegro (not (or allegro-v5.0 allegro-v4.3.1 allegro-v4.3 allegro-v4.2 (and lucid solaris)))) "allegro") #+:lucid (software-type-translation "Unix" #+:lcl4.1 "4.1" #+(and :lcl4.0 (not :lcl4.1)) "4.0" #+(and :lcl3.0 (not :lcl4.0)) "3.0") #+(and lucid (not solaris)) (software-type-translation "SunOS" #+:lcl4.1 "4.1" #+(and :lcl4.0 (not :lcl4.1)) "4.0" #+(and :lcl3.0 (not :lcl4.0)) "3.0") #+:lucid (software-type-translation "HP-UX" #+:lcl4.1 "L4.1" #+(and :lcl4.0 (not :lcl4.1)) "L4.0" #+(and :lcl3.0 (not :lcl4.0)) "L3.0" #-(or :lcl4.1 :lcl4.0 :lcl3.0) "LUCID") (software-type-translation "AIX" #+:allegro-v4.2 "allegro4.2" #+:allegro-v4.3 "allegro4.3" #+:allegro-v4.3.1 "allegro4.3.1" #+:allegro-v5.0 "allegro5.0" #-(or allegro-v5.0 allegro-v4.3.1 allegro-v4.3 allegro-v4.2) "aix") (software-type-translation "DEC ULTRIX" "lcl4.0") (software-type-translation "OSF1" "lispworks"))) ; Added for afs-binary-directory to work out properly. BKay 31Aug96: (setq *bin-subdir* "bins/") (defun get-bin-dir-name () (if (and (machine-type-translation (machine-type)) (software-type-translation (software-type))) (afs-component (machine-type-translation (machine-type)) (software-type-translation (software-type))) (describe-add-translation))) (defun describe-add-translation () (format t "~%~% BINARY DIRECTORY TRANSLATION TABLE MUST BE MODIFIED Two translation tables are used to determine the binary directory name. The name is determined by concatenating the value returned from these two tables. The tables translate the values returned by the functions machine-type and software-type into strings. These functions currently return the following values and the following translation is defined: Function ~20T Returns ~40T Translation --------------- ~20T --------------- ~40T ------------------------ machine-type ~20T ~a~40T ~a software-type ~20T ~a~40T ~a To add a translation or change a translation to either the software tranlsation table or the hardware translation table, add one or both of the following declarations to the file start-nq.lisp after the common lisp defsystem is loaded. A translation string must be added to these declarations. (machine-type-translation \"~a\" \"\") (software-type-translation \"~a\" \"\") " (machine-type) (software-type) (machine-type-translation (machine-type)) (software-type-translation (software-type)) (machine-type) (software-type)) nil) (defun afs-component-error-message (mach soft) (format nil " PLEASE READ CAREFULLY. The name for the binary directory is determined by looking in tables defined in the file c-lisp/new-defsystem.lisp. The first portion of the binary directory name is determined by the machine-type and the second portion is determined by the software-type. However -- ~:[~; The machine type is not defined.~] ~:[~; The software type is not defined.~] You must add the following line(s) to a patch file which will be loaded each time QSIM is loaded. ~@[ (machine-type-translation \"~A\" \"\")~] ~@[ (software-type-translation \"~A\" \"\")~] The (s) should be chosen by you. If you wish to continue compilation you can set the value(s) of the machine and/or software translation variables to their respective translation string(s) now." (null mach) (null soft) (when (null mach) (machine-type)) (when (null soft) (software-type)))) ; Check that argumentw are non-nil and generate error message if not. ; Current UT directory structure has no component for lisp. (defun afs-component (machine software &optional lisp) (let ((*print-escape* nil)) (assert (and machine software) (machine software) (afs-component-error-message machine software))) (format nil "~@[~A~]~@[_~A~]~@[_~A~]" machine (or software "mach") lisp)) ; parameter *filename-extensions* now properly defined in defsystem.lisp. ; RM 01 Mar 97. (assert *filename-extensions* (*filename-extensions*) " The variable *filename-extensions* is a cons of the filename extensions for the source and the binary extensions for your system. Please add a condition for your system for the definition of this variable in the file c-lisp/defsystem.lisp. You can set this variable manually now to conitnue.") #+:lucid (defun COMPILE-SYSTEM (name &key force (version *version*) (test *oos-test*) (verbose *oos-verbose*) (load-source-instead-of-binary *load-source-instead-of-binary*) (load-source-if-no-binary *load-source-if-no-binary*) (bother-user-if-no-binary *bother-user-if-no-binary*) dribble (minimal-load *minimal-load*)) ;; For users who are confused by OOS. (with-deferred-warnings (operate-on-system name :compile :force force :version version :test test :verbose verbose :load-source-instead-of-binary load-source-instead-of-binary :load-source-if-no-binary load-source-if-no-binary :bother-user-if-no-binary bother-user-if-no-binary :dribble dribble :minimal-load minimal-load))) ; The following works in allegro-v4.1 and above. BKay 2Sep96. ; Moved here from defsystem.lisp. Rich Mallory 7 Mar 97. #+(and (and allegro-version>= (version>= 4 1)) (not :logical-pathnames-mk)) (defun append-logical-directories-mk (absolute-dir relative-dir) (when (or absolute-dir relative-dir) (setq absolute-dir (logical-pathname (or absolute-dir "")) relative-dir (logical-pathname (or relative-dir ""))) ;; This used to be a call to translate-logical-pathname which results in a ;; physical pathname. Thus, appending multiple logical pathname segments ;; would always fail since append-directories would see a physical ;; pathname as the absolute directory and a logical pathname as a relative ;; directory. With the call to logical-pathname, the resulting path ;; should remain logical. BKay 2Sep96. (logical-pathname (make-pathname :host (or (pathname-host absolute-dir) (pathname-host relative-dir)) :directory (append (pathname-directory absolute-dir) (cdr (pathname-directory relative-dir))) :name (or (pathname-name absolute-dir) (pathname-name relative-dir)) :type (or (pathname-type absolute-dir) (pathname-type relative-dir)) :version (or (pathname-version absolute-dir) (pathname-version relative-dir)))))) ; From defsystem.lisp. Failed to convert logical pathnames to physical, as ; mentioned in the long comment, since translate-logical-pathname was prefixed ; by #+(and (and allegro-version>= (version>= 4 1)) ; (not :logical-pathnames-mk)) ; Rich Mallory 7 Mar 97. (defun component-full-pathname-i (component type &optional (version *version*)) ;; If the pathname-type is :binary and the root pathname is null, ;; distribute the binaries among the sources (= use :source pathname). ;; This assumes that the component's :source pathname has been set ;; before the :binary one. (multiple-value-bind (version-dir version-replace) (if version (translate-version version) (values *version-dir* *version-replace*)) (let ((pathname ; type string, not pathname (append-directories (if version-replace version-dir (append-directories (component-root-dir component type) version-dir)) (component-pathname component type)))) ;; When a logical pathname is used, it must first be translated to a ;; physical pathname. This isn't strictly correct. What should happen ;; is we fill in the appropriate slots of the logical pathname, and then ;; return the logical pathname for use by compile-file and friends. But ;; calling translate-logical-pathname to return the physical pathname ;; should do for now. #+:logical-pathnames-mk (when (eq (lp:pathname-host-type pathname) :logical) (setf pathname (lp:translate-logical-pathname pathname))) #+(not :logical-pathnames-mk) (when (and (pathname-host pathname) #+(and allegro-version>= (version>= 4 1)) (logical-pathname-p pathname)) ;; Lispworks translate-logical-pathname sometimes fails coerce its ;; pathname argument to a pathname if it is a string or stream. See ;; CLtL2, page 613. Rich Mallory 7 Mar 97: (setf pathname (translate-logical-pathname (pathname pathname)))) (namestring (make-pathname :host ;; MCL2.0b1 and ACLPC cause an error on (pathname-host nil) (let ((hst (component-host component))) (when hst (pathname-host hst))) ;; Use :directory instead of :defaults :directory (pathname-directory pathname) :name (pathname-name pathname) :type (component-extension component type) ;; :version :newest :device #+(and :cmu (not :cmu17)) :absolute #-(and :cmu (not :cmu17)) (let ((dev (component-device component))) (when dev (pathname-device dev))) )))))