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 SB-XC:*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 (unless (find-package "SB-XC")
  22   (make-package "SB-XC" :use nil :nicknames nil))
  23 (export (intern "*FEATURES*" "SB-XC") "SB-XC")
  24 (declaim (type list sb-xc:*features*))
  25 (defvar sb-xc:*features*)
  26
  27 (defun target-platform-keyword (&aux (features sb-xc:*features*))
  28   (let ((arch (intersection '(:arm :arm64 :mips :ppc :ppc64 :riscv :sparc :x86 :x86-64)
  29                             features)))
  30     (cond ((not arch) (error "No architecture selected"))
  31           ((> (length arch) 1) (error "More than one architecture selected")))
  32     (car arch)))
  33
  34 (defun compatible-vector-raw-bits () ; T if the host and target match on word size and endianness
  35   (flet ((endianness (features)
  36            (let ((result (intersection '(:little-endian :big-endian) features)))
  37              ;; some lisp implementation may not have little-endian / big-endian
  38              ;; features which shouldn't trigger that assert
  39              (assert (or (not result) (and result (not (cdr result)))))
  40              (car result)))
  41          (wordsize (features)
  42            (if (member :64-bit features) 64 32)))
  43     (and (eq (endianness sb-xc:*features*) (endianness cl:*features*))
  44          (= (wordsize sb-xc:*features*) (wordsize cl:*features*)))))
  45
  46 ;;; Not necessarily the logical place to define BACKEND-ASM-PACKAGE-NAME,
  47 ;;; but a convenient one.
  48 (defun backend-assembler-target-name ()
  49   (let ((keyword (target-platform-keyword)))
  50     (case keyword
  51       (:ppc :ppc64)
  52       (t keyword))))
  53 (defun backend-asm-package-name ()
  54   (concatenate 'string "SB-" (string (backend-assembler-target-name)) "-ASM"))
  55
  56 ;;; Like the real FEATUREP but using SB-XC:*FEATURES* instead of CL:*FEATURES*
  57 (defun target-featurep (feature)
  58   (etypecase feature
  59     (symbol
  60      (if (string= feature "SBCL")
  61          (error "Testing SBCL as a target feature is obviously bogus")
  62          (member feature sb-xc:*features* :test #'eq)))
  63     (cons (ecase (first feature)
  64             (:or  (some  #'target-featurep (rest feature)))
  65             (:and (every #'target-featurep (rest feature)))
  66             (:not (destructuring-bind (subexpr) (cdr feature)
  67                     (not (target-featurep subexpr))))))))
  68 (compile 'target-featurep)
  69
  70 (defun read-targ-feature-expr (stream sub-character infix-parameter)
  71   (when infix-parameter
  72     (error "illegal read syntax: #~D!" infix-parameter))
  73   (if (char= (if (let* ((*package* (find-package "KEYWORD"))
  74                         (*read-suppress* nil)
  75                         (feature (read stream t nil t)))
  76                    (target-featurep feature))
  77                  #\+ #\-)
  78              sub-character)
  79       (read stream t nil t)
  80       ;; Read (and discard) a form from input.
  81       (let ((*read-suppress* t))
  82         (read stream t nil t)
  83         (values))))
  84 (compile 'read-targ-feature-expr)
  85
  86 (export '*xc-readtable*)
  87 (defvar *xc-readtable* (copy-readtable))
  88 (set-dispatch-macro-character #\# #\+ #'read-targ-feature-expr *xc-readtable*)
  89 (set-dispatch-macro-character #\# #\- #'read-targ-feature-expr *xc-readtable*)
  90
  91 (defvar *consing-dot*)
  92
  93 (defun read-potential-real-number (stream char)
  94   (let ((buffer (load-time-value
  95                  ;; Assume that we don't have any potential number
  96                  ;; tokens that are too long.
  97                  (make-array 100 :element-type 'character
  98                                  :fill-pointer 0))))
  99     (setf (aref buffer 0) char)
 100     (setf (fill-pointer buffer) 1)
 101     (loop
 102       (let ((char (peek-char nil stream nil nil t))
 103             (char-skipping-whitespace (peek-char t stream nil nil t)))
 104         ;; Check for EOF, delimiting whitespace, or terminating macro
 105         ;; character.
 106         (when (or (null char)
 107                   (not (eql char char-skipping-whitespace))
 108                   (multiple-value-bind (function non-terminating-p)
 109                       (get-macro-character char)
 110                     (and function (not non-terminating-p))))
 111           (return))
 112         (vector-push (read-char stream t nil t) buffer)))
 113     (when (and (eql char #\.) (= (length buffer) 1))
 114       (unless (boundp '*consing-dot*)
 115         (if *read-suppress*
 116             (return-from read-potential-real-number nil)
 117             (error ". not inside list.")))
 118       (return-from read-potential-real-number *consing-dot*))
 119     (when *read-suppress*
 120       (return-from read-potential-real-number nil))
 121     ;; Check using the host reader whether we would get a float
 122     ;; literal. If so, read in the float in the target format.
 123     (let ((*readtable* (load-time-value (copy-readtable nil))))
 124       (multiple-value-bind (object position) (read-from-string buffer)
 125         ;; Assert that we tokenized the same number of characters as
 126         ;; the reader did with the standard syntax.
 127         (assert (= (length buffer) position))
 128         (if (cl:floatp object)
 129             (funcall 'read-target-float-from-string buffer)
 130             object)))))
 131
 132 (compile 'read-potential-real-number)
 133
 134 ;;; Treat every potential initial character for a base-10 real number
 135 ;;; as a reader macro.
 136 (dolist (char (coerce ".-+0123456789" 'list))
 137   (set-macro-character char #'read-potential-real-number t *xc-readtable*))
 138
 139 (defun read-maybe-nothing (stream)
 140   (let* ((char (read-char stream t nil t)) ; not whitespace
 141          (function (get-macro-character char)))
 142     (cond (function
 143            (multiple-value-call (lambda (&rest args)
 144                                   (if (null args)
 145                                       (values nil t)
 146                                       (values (first args) nil)))
 147              (funcall function stream char)))
 148           (t
 149            (unread-char char stream)
 150            (read stream t nil t)))))
 151
 152 (compile 'read-maybe-nothing)
 153
 154 (defun read-after-dot (stream)
 155   (loop
 156     (when (eql (peek-char t stream t nil t) #\))
 157       (if *read-suppress*
 158           (return-from read-after-dot nil)
 159           (error "Nothing appears after . in list.")))
 160     (multiple-value-bind (object skipped)
 161         (read-maybe-nothing stream)
 162       (unless skipped
 163         (return
 164           (loop
 165             (cond ((eql (peek-char t stream t nil t) #\))
 166                    (return object))
 167                   ((and (not (nth-value 1 (read-maybe-nothing stream)))
 168                         (not *read-suppress*))
 169                    (error "More than one object follows . in list.")))))))))
 170
 171 (compile 'read-after-dot)
 172
 173 (defun read-list (stream ignore)
 174   (declare (ignore ignore))
 175   (let* ((read-suppress *read-suppress*)
 176          (list (list nil))
 177          (tail list)
 178          (*consing-dot* list))
 179     (declare (dynamic-extent list))
 180     (loop
 181       (when (eq (peek-char t stream t nil t) #\))
 182         (read-char stream)
 183         (return (cdr list)))
 184       (multiple-value-bind (object skipped)
 185           (read-maybe-nothing stream)
 186         (cond ((eq object *consing-dot*)
 187                (when (eq list tail)
 188                  (unless read-suppress
 189                    (error "Nothing appears before . in list.")))
 190                (rplacd tail (read-after-dot stream)))
 191               ((and (not skipped) (not read-suppress))
 192                (setq tail
 193                      (cdr (rplacd tail (list object))))))))))
 194
 195 (compile 'read-list)
 196
 197 ;;; We need to install our own left parenthesis reader macro to make
 198 ;;; it communicate with the dot reader macro for reading real numbers,
 199 ;;; since #\. can be used both as an initial float character as well
 200 ;;; as a consing dot in the standard syntax. Although sbcl (and cmu
 201 ;;; cl) themselves as a host lisps do not need this for consing dot to
 202 ;;; work, other implementations do, and it's ambiguous whether this is
 203 ;;; strictly necessary.
 204 (set-macro-character #\( #'read-list nil *xc-readtable*)
 205
 206 ;;; The reader will be defined during compilation. CLISP does not permit assignment
 207 ;;; of a symbol that currently has no functional definition, so wrap it in lambda.
 208 (set-dispatch-macro-character #\# #\c
 209   (lambda (stream sub-char numarg)
 210     (funcall 'read-target-complex stream sub-char numarg))
 211   *xc-readtable*)
 212
 213 ;;; ECL needs a bit of help:
 214 ;;; https://gitlab.com/embeddable-common-lisp/ecl/-/issues/742
 215 #+ecl
 216 (macrolet ((frob (char base)
 217              `(set-dispatch-macro-character #\# ,char
 218                 (lambda (stream sub-char numarg)
 219                   (declare (ignore sub-char))
 220                   (declare (ignorable numarg))
 221                   (let ((*read-base* ,base))
 222                     (read stream t nil t)))
 223                 *xc-readtable*)))
 224   (frob #\r numarg)
 225   (frob #\x 16)
 226   (frob #\o 8)
 227   (frob #\b 2))
 228 \f
 229 ;;;; string checker, for catching non-portability early
 230
 231 (defun make-quote-reader (standard-quote-reader)
 232   (lambda (stream char)
 233     (let ((result (funcall standard-quote-reader stream char)))
 234       (unless (every (lambda (x) (typep x 'standard-char)) result)
 235         (warn "Found non-STANDARD-CHAR in ~S" result))
 236       result)))
 237 (compile 'make-quote-reader)
 238 (set-macro-character #\" (make-quote-reader (get-macro-character #\" nil))
 239                      nil *xc-readtable*)