src/cold/shebang.lisp

   1 ;;;; cold-boot-only readmacro syntax
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB-COLD")
  13 \f
  14 ;;;; definition of #!+ and #!- as a mechanism analogous to #+/#-, but
  15 ;;;; for *SHEBANG-FEATURES* instead of CL:*FEATURES*. (This is handy
  16 ;;;; when cross-compiling, so that we can make a distinction between
  17 ;;;; features of the host Common Lisp and features of the target
  18 ;;;; SBCL.)
  19
  20 ;;; the feature list for the target system
  21 (export '*shebang-features*)
  22 (declaim (type list *shebang-features*))
  23 ;; FIXME: is there a reason this isn't SB!XC:*FEATURES* ?
  24 ;; We haven't set up the SB!XC package yet, but we certainly could.
  25 (defvar *shebang-features*)
  26
  27 (defun target-platform-name ()
  28   (let ((arch (intersection '(:alpha :arm :arm64 :hppa :mips :ppc :sparc :x86 :x86-64)
  29                             *shebang-features*)))
  30     (cond ((not arch) (error "No architecture selected"))
  31           ((> (length arch) 1) (error "More than one architecture selected")))
  32     (string-downcase (car arch))))
  33
  34 ;;; Not necessarily the logical place to define BACKEND-ASM-PACKAGE-NAME,
  35 ;;; but a convenient one, because *shebang-features* needs to have been
  36 ;;; DEFVARed, and because 'chill' loads this and only this file.
  37 (defun backend-asm-package-name ()
  38   (concatenate 'string "SB!" (string-upcase (target-platform-name)) "-ASM"))
  39
  40 (defun feature-in-list-p (feature list)
  41   (labels ((sane-expr-p (x)
  42              (typecase x
  43                (symbol (and (string/= x "SB-XC") (string/= x "SB-XC-HOST")))
  44                ;; This allows you to write #!+(host-feature sbcl) <stuff>
  45                ;; to muffle conditions, bypassing the "probable XC bug" check.
  46                ;; Using the escape hatch is assumed never to be a mistake.
  47                ((cons (eql :host-feature)) t)
  48                (cons (every #'sane-expr-p (cdr x))))))
  49     (unless (sane-expr-p feature)
  50       (error "Target feature expression ~S looks screwy" feature)))
  51   (etypecase feature
  52     (symbol (member feature list :test #'eq))
  53     (cons (flet ((subfeature-in-list-p (subfeature)
  54                    (feature-in-list-p subfeature list)))
  55             (ecase (first feature)
  56               (:or  (some  #'subfeature-in-list-p (rest feature)))
  57               (:and (every #'subfeature-in-list-p (rest feature)))
  58               ((:host-feature :not)
  59                (destructuring-bind (subexpr) (cdr feature)
  60                  (cond ((eq (first feature) :host-feature)
  61                         ;; (:HOST-FEATURE :sym) looks in *FEATURES* for :SYM
  62                         (check-type subexpr symbol)
  63                         (member subexpr *features* :test #'eq))
  64                        (t
  65                         (not (subfeature-in-list-p subexpr)))))))))))
  66 (compile 'feature-in-list-p)
  67
  68 (defun shebang-reader (stream sub-character infix-parameter)
  69   (declare (ignore sub-character))
  70   (when infix-parameter
  71     (error "illegal read syntax: #~D!" infix-parameter))
  72   (let ((next-char (read-char stream)))
  73     (unless (find next-char "+-")
  74       (error "illegal read syntax: #!~C" next-char))
  75     (if (char= (if (let* ((*package* (find-package "KEYWORD"))
  76                           (*read-suppress* nil)
  77                           (feature (read stream)))
  78                      (feature-in-list-p feature *shebang-features*))
  79                    #\+ #\-) next-char)
  80         (read stream t nil t)
  81         ;; Read (and discard) a form from input.
  82         (let ((*read-suppress* t))
  83           (read stream t nil t)
  84           (values)))))
  85 (compile 'shebang-reader)
  86
  87 (set-dispatch-macro-character #\# #\! #'shebang-reader)
  88 ;;; while we are at it, let us write something which helps us sanity
  89 ;;; check our own code; it is too easy to write #+ when meaning #!+,
  90 ;;; and such mistakes can go undetected for a while.
  91 ;;;
  92 ;;; ideally we wouldn't use *SHEBANG-FEATURES* but
  93 ;;; *ALL-POSSIBLE-SHEBANG-FEATURES*, but maintaining that variable
  94 ;;; will not be easy.
  95 (defun checked-feature-in-features-list-p (feature list)
  96   (etypecase feature
  97     (symbol (unless (member feature '(:ansi-cl :common-lisp :ieee-floating-point))
  98               (when (member feature *shebang-features* :test #'eq)
  99                 (error "probable XC bug in host read-time conditional: ~S" feature)))
 100             (member feature list :test #'eq))
 101     (cons (flet ((subfeature-in-list-p (subfeature)
 102                    (checked-feature-in-features-list-p subfeature list)))
 103             (ecase (first feature)
 104               (:or  (some  #'subfeature-in-list-p (rest feature)))
 105               (:and (every #'subfeature-in-list-p (rest feature)))
 106               (:not (let ((rest (cdr feature)))
 107                       (if (or (null (car rest)) (cdr rest))
 108                         (error "wrong number of terms in compound feature ~S"
 109                                feature)
 110                         (not (subfeature-in-list-p (second feature)))))))))))
 111 (compile 'checked-feature-in-features-list-p)
 112
 113 (defun she-reader (stream sub-character infix-parameter)
 114   (when infix-parameter
 115     (error "illegal read syntax: #~D~C" infix-parameter sub-character))
 116   (when (let* ((*package* (find-package "KEYWORD"))
 117                (*read-suppress* nil)
 118                (notp (eql sub-character #\-))
 119                (feature (read stream)))
 120           (if (checked-feature-in-features-list-p feature *features*)
 121               notp
 122               (not notp)))
 123     (let ((*read-suppress* t))
 124       (read stream t nil t)))
 125   (values))
 126 (compile 'she-reader)
 127 \f
 128 ;;;; variables like *SHEBANG-FEATURES* but different
 129
 130 ;;; This variable is declared here (like *SHEBANG-FEATURES*) so that
 131 ;;; things like chill.lisp work (because the variable has properties
 132 ;;; similar to *SHEBANG-FEATURES*, and chill.lisp was set up to work
 133 ;;; for that). For an explanation of what it really does, look
 134 ;;; elsewhere.
 135 (export '*shebang-backend-subfeatures*)
 136 (declaim (type list *shebang-backend-subfeatures*))
 137 (defvar *shebang-backend-subfeatures*)
 138 \f
 139 ;;;; string checker, for catching non-portability early
 140 (defun make-quote-reader (standard-quote-reader)
 141   (lambda (stream char)
 142     (let ((result (funcall standard-quote-reader stream char)))
 143       (unless (every (lambda (x) (typep x 'standard-char)) result)
 144         (warn "Found non-STANDARD-CHAR in ~S" result))
 145       result)))
 146 (compile 'make-quote-reader)
 147
 148 (set-macro-character #\" (make-quote-reader (get-macro-character #\" nil)))