From ccfce15277c9da810ef38e1613c325cb1dbaa3f6 Mon Sep 17 00:00:00 2001 From: gerd <gerd> Date: Fri, 20 Jun 2003 11:06:15 +0000 Subject: [PATCH] * src/bootfiles/18e/boot13.lisp (relative-package-name-to-package) (read-token): Add. (toplevel): Set the readtable entry for #\: to the new read-token. --- bootfiles/18e/boot13.lisp | 377 ++++++++++++++++++++++++++++++++++++-- 1 file changed, 366 insertions(+), 11 deletions(-) diff --git a/bootfiles/18e/boot13.lisp b/bootfiles/18e/boot13.lisp index 0929e20fa..730fe263f 100644 --- a/bootfiles/18e/boot13.lisp +++ b/bootfiles/18e/boot13.lisp @@ -8,19 +8,374 @@ ;;; using Pierre Mai's build scripts, and do a full build. ;;; -;;; -;;; Remove the nickname "" from the KEYWORD package. -;;; -;;; Remove the nickname USER from CL-USER. -;;; -;;; Make a new package COMMON-LISP, from which LISP inherits -;;; the standard symbols. -;;; -;;; Move DEBUG and FLOATING-POINT-INEXACT from EXT to CL. -;;; - (in-package :lisp) +#+relative-package-names +(defun relative-package-name-to-package (name) + (declare (simple-string name) + (optimize (speed 3))) + (flet ((relative-to (package name) + (declare (type package package) + (simple-string name)) + (if (string= "" name) + package + (let ((parent-name (package-%name package))) + (unless parent-name + (error "Can't do anything to a deleted package: ~S" + package)) + (package-name-to-package + (concatenate 'simple-string parent-name "." name))))) + (find-non-dot (name) + (do* ((len (length name)) + (i 0 (1+ i))) + ((= i len) nil) + (declare (type index len i)) + (when (char/= #\. (schar name i)) (return i))))) + (when (and (plusp (length name)) + (char= #\. (schar name 0))) + (let* ((last-dot-position (or (find-non-dot name) (length name))) + (n-dots last-dot-position) + (name (subseq name last-dot-position))) + (cond ((= 1 n-dots) + ;; relative to current package + (relative-to *package* name)) + (t + ;; relative to our (- n-dots 1)'th parent + (let ((package *package*) + (tmp nil)) + (dotimes (i (1- n-dots)) + (declare (fixnum i)) + (setq tmp (package-parent package)) + (unless tmp + (error 'simple-package-error + :name (string package) + :format-control "The parent of ~a does not exist." + :format-arguments (list package))) + (setq package tmp)) + (relative-to package name)))))))) + +(defun read-token (stream firstchar) + "This function is just an fsm that recognizes numbers and symbols." + ;;check explicitly whether firstchar has entry for non-terminating + ;;in character-attribute-table and read-dot-number-symbol in CMT. + ;;Report an error if these are violated (if we called this, we want + ;;something that is a legitimate token!). + ;;read in the longest possible string satisfying the bnf for + ;;"unqualified-token". Leave the result in the READ-BUFFER. + ;;Return next char after token (last char read). + (when *read-suppress* + (internal-read-extended-token stream firstchar nil) + (return-from read-token nil)) + (let ((attribute-table (character-attribute-table *readtable*)) + (package nil) + (colons 0) + (possibly-rational t) + (possibly-float t) + (escapes ())) + (reset-read-buffer) + (prog ((char firstchar)) + (case (char-class3 char attribute-table) + (#.constituent-sign (go SIGN)) + (#.constituent-digit (go LEFTDIGIT)) + (#.constituent-dot (go FRONTDOT)) + (#.escape (go ESCAPE)) + (#.package-delimiter (go COLON)) + (#.multiple-escape (go MULT-ESCAPE)) + ;;can't have eof, whitespace, or terminating macro as first char! + (t (go SYMBOL))) + SIGN + ;;saw "sign" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (setq possibly-rational t + possibly-float t) + (case (char-class3 char attribute-table) + (#.constituent-digit (go LEFTDIGIT)) + (#.constituent-dot (go SIGNDOT)) + (#.escape (go ESCAPE)) + (#.package-delimiter (go COLON)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) + (t (go SYMBOL))) + LEFTDIGIT + ;;saw "[sign] {digit}+" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (return (make-integer))) + (case (char-class3 char attribute-table) + (#.constituent-digit (go LEFTDIGIT)) + (#.constituent-dot (if possibly-float + (go MIDDLEDOT) + (go SYMBOL))) + (#.constituent-expt (go EXPONENT)) + (#.constituent-slash (if possibly-rational + (go RATIO) + (go SYMBOL))) + (#.delimiter (unread-char char stream) (return (make-integer))) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + MIDDLEDOT + ;;saw "[sign] {digit}+ dot" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (return (let ((*read-base* 10)) + (make-integer)))) + (case (char-class char attribute-table) + (#.constituent-digit (go RIGHTDIGIT)) + (#.constituent-expt (go EXPONENT)) + (#.delimiter + (unread-char char stream) + (return (let ((*read-base* 10)) + (make-integer)))) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + RIGHTDIGIT + ;;saw "[sign] {digit}* dot {digit}+" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (return (make-float))) + (case (char-class char attribute-table) + (#.constituent-digit (go RIGHTDIGIT)) + (#.constituent-expt (go EXPONENT)) + (#.delimiter (unread-char char stream) (return (make-float))) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + SIGNDOT + ;;saw "[sign] dot" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.constituent-digit (go RIGHTDIGIT)) + (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (t (go SYMBOL))) + FRONTDOT + ;;saw "dot" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (%reader-error stream "Dot context error.")) + (case (char-class char attribute-table) + (#.constituent-digit (go RIGHTDIGIT)) + (#.constituent-dot (go DOTS)) + (#.delimiter (%reader-error stream "Dot context error.")) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + EXPONENT + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.constituent-sign (go EXPTSIGN)) + (#.constituent-digit (go EXPTDIGIT)) + (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + EXPTSIGN + ;;we got to EXPONENT, and saw a sign character. + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.constituent-digit (go EXPTDIGIT)) + (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + EXPTDIGIT + ;;got to EXPONENT, saw "[sign] {digit}+" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (return (make-float))) + (case (char-class char attribute-table) + (#.constituent-digit (go EXPTDIGIT)) + (#.delimiter (unread-char char stream) (return (make-float))) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + RATIO + ;;saw "[sign] {digit}+ slash" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class2 char attribute-table) + (#.constituent-digit (go RATIODIGIT)) + (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + RATIODIGIT + ;;saw "[sign] {digit}+ slash {digit}+" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (return (make-ratio))) + (case (char-class2 char attribute-table) + (#.constituent-digit (go RATIODIGIT)) + (#.delimiter (unread-char char stream) (return (make-ratio))) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + DOTS + ;;saw "dot {dot}+" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (%reader-error stream "Too many dots.")) + (case (char-class char attribute-table) + (#.constituent-dot (go DOTS)) + (#.delimiter + (unread-char char stream) + (%reader-error stream "Too many dots.")) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + SYMBOL + ;;not a dot, dots, or number. + (let ((stream (in-synonym-of stream))) + (if (lisp-stream-p stream) + (prepare-for-fast-read-char stream + (prog () + SYMBOL-LOOP + (ouch-read-buffer char) + (setq char (fast-read-char nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.escape (done-with-fast-read-char) + (go ESCAPE)) + (#.delimiter (done-with-fast-read-char) + (unread-char char stream) + (go RETURN-SYMBOL)) + (#.multiple-escape (done-with-fast-read-char) + (go MULT-ESCAPE)) + (#.package-delimiter (done-with-fast-read-char) + (go COLON)) + (t (go SYMBOL-LOOP))))) + ;; Fundamental-stream. + (prog () + SYMBOL-LOOP + (ouch-read-buffer char) + (setq char (stream-read-char stream)) + (when (eq char :eof) (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.escape (go ESCAPE)) + (#.delimiter (stream-unread-char stream char) + (go RETURN-SYMBOL)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL-LOOP)))))) + ESCAPE + ;;saw an escape. + ;;don't put the escape in the read-buffer. + ;;read-next char, put in buffer (no case conversion). + (let ((nextchar (read-char stream nil nil))) + (unless nextchar + (reader-eof-error stream "after escape character")) + (push ouch-ptr escapes) + (ouch-read-buffer nextchar)) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + MULT-ESCAPE + (do ((char (read-char stream t) (read-char stream t))) + ((multiple-escape-p char)) + (if (escapep char) (setq char (read-char stream t))) + (push ouch-ptr escapes) + (ouch-read-buffer char)) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + COLON + (casify-read-buffer escapes) + (unless (zerop colons) + (%reader-error stream "Too many colons in ~S" + (read-buffer-to-string))) + (setq colons 1) + (setq package + (if (eql (char-class firstchar attribute-table) + #.package-delimiter) + *keyword-package* + (read-buffer-to-string))) + (reset-read-buffer) + (setq escapes ()) + (setq char (read-char stream nil nil)) + (unless char (reader-eof-error stream "after reading a colon")) + (case (char-class char attribute-table) + (#.delimiter + (unread-char char stream) + (%reader-error stream "Illegal terminating character after a colon, ~S." + char)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go INTERN)) + (t (go SYMBOL))) + INTERN + (setq colons 2) + (setq char (read-char stream nil nil)) + (unless char + (reader-eof-error stream "after reading a colon")) + (case (char-class char attribute-table) + (#.delimiter + (unread-char char stream) + (%reader-error stream "Illegal terminating character after a colon, ~S" + char)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter + (%reader-error stream "To many colons after ~S:" package)) + (t (go SYMBOL))) + RETURN-SYMBOL + (casify-read-buffer escapes) + (let ((found (if package + (find-package package) + *package*))) + (unless found + (error 'reader-package-error :stream stream + :format-arguments (list package) + :format-control "Package ~S not found.")) + + (if (or (zerop colons) (= colons 2) (eq found *keyword-package*)) + (return (intern* read-buffer ouch-ptr found)) + (multiple-value-bind (symbol test) + (find-symbol* read-buffer ouch-ptr found) + (when (eq test :external) (return symbol)) + (let ((name (read-buffer-to-string))) + (with-simple-restart (continue "Use symbol anyway.") + (error 'reader-package-error :stream stream + :format-arguments (list name (package-name found)) + :format-control + (if test + "The symbol ~S is not external in the ~A package." + "Symbol ~S not found in the ~A package."))) + (return (intern name found))))))))) + +(set-cmt-entry #\: #'read-token) + (rename-package "KEYWORD" "KEYWORD" nil) (cl:rename-package "COMMON-LISP-USER" "COMMON-LISP-USER" '("CL-USER")) -- GitLab