hash p write pathname (#1612)
* #P"pathname" reads in as pathname * #P"pathname" used for printing pathnames * remake to remove extraneous reprint of CMLPATHNAMECOMS
This commit is contained in:
Larry Masinter
GitHub
parent
d5cc219895
commit
44b1f8a7f3
@ -1,12 +1,10 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 1-May-2023 07:12:28" {DSK}<home>larry>il>medley>sources>CMLPATHNAME.;5 30540
|
||||
(FILECREATED " 9-Apr-2024 12:59:40" {DSK}<home>larry>il>medley>sources>CMLPATHNAME.;2 32347
|
||||
|
||||
:EDIT-BY "lmm"
|
||||
|
||||
:CHANGES-TO (FNS PATHNAME)
|
||||
|
||||
:PREVIOUS-DATE "30-Apr-2023 14:00:37" {DSK}<home>larry>il>medley>sources>CMLPATHNAME.;4)
|
||||
:PREVIOUS-DATE "23-Mar-2024 22:31:11" {DSK}<home>larry>il>medley>sources>CMLPATHNAME.;1)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT CMLPATHNAMECOMS)
|
||||
@ -40,8 +38,8 @@
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
(ADDVARS (NLAMA)
|
||||
(NLAML)
|
||||
(LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES
|
||||
PATHNAME %%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME])
|
||||
(LAMA CL:ENOUGH-NAMESTRING CL:MERGE-PATHNAMES CL:MAKE-PATHNAME %%PRINT-PATHNAME
|
||||
])
|
||||
|
||||
|
||||
|
||||
@ -84,8 +82,10 @@
|
||||
(DEFINEQ
|
||||
|
||||
(%%PRINT-PATHNAME
|
||||
(CL:LAMBDA (S STREAM D) (* hdj "19-Sep-86 15:49") (DECLARE (IGNORE D)) (CL:FORMAT STREAM "#.(~S ~S)" (QUOTE PATHNAME) (CL:NAMESTRING S)))
|
||||
)
|
||||
(CL:LAMBDA (S STREAM D) (* ; "Edited 23-Mar-2024 22:25 by lmm")
|
||||
(* hdj "19-Sep-86 15:49")
|
||||
(DECLARE (IGNORE D))
|
||||
(CL:FORMAT STREAM "#P~S" (CL:NAMESTRING S))))
|
||||
|
||||
(CL:MAKE-PATHNAME
|
||||
(CL:LAMBDA (&KEY DEFAULTS (HOST NIL HOSTP)
|
||||
@ -500,21 +500,62 @@
|
||||
|
||||
(ADDTOVAR NLAML )
|
||||
|
||||
(ADDTOVAR LAMA CL:ENOUGH-NAMESTRING CL:MERGE-PATHNAMES CL:MAKE-PATHNAME %%PRINT-PATHNAME)
|
||||
)
|
||||
(PRETTYCOMPRINT CMLPATHNAMECOMS)
|
||||
|
||||
(RPAQQ CMLPATHNAMECOMS
|
||||
[
|
||||
(* ;; "Common Lisp pathname functions")
|
||||
|
||||
(PROP FILETYPE CMLPATHNAME)
|
||||
(COMS
|
||||
(* ;; "useful macros")
|
||||
|
||||
(FUNCTIONS %%WILD-NAME %%COMPONENT-STRING))
|
||||
(STRUCTURES PATHNAME DIRECTORY-COMPONENT)
|
||||
(FNS %%PRINT-PATHNAME CL:MAKE-PATHNAME %%PRINT-DIRECTORY-COMPONENT)
|
||||
(FUNCTIONS CL:PATHNAME-HOST CL:PATHNAME-DEVICE CL:PATHNAME-DIRECTORY CL:PATHNAME-NAME
|
||||
CL:PATHNAME-TYPE CL:PATHNAME-VERSION)
|
||||
(FNS PATHNAME CL:MERGE-PATHNAMES FILE-NAME CL:HOST-NAMESTRING CL:ENOUGH-NAMESTRING
|
||||
%%NUMERIC-STRING-P)
|
||||
(FUNCTIONS CL:NAMESTRING CL:PARSE-NAMESTRING CL:TRUENAME)
|
||||
(FUNCTIONS %%MAKE-PATHNAME)
|
||||
(FUNCTIONS %%PATHNAME-EQUAL %%DIRECTORY-COMPONENT-EQUAL)
|
||||
(FUNCTIONS %%INITIALIZE-DEFAULT-PATHNAME)
|
||||
(VARIABLES *DEFAULT-PATHNAME-DEFAULTS*)
|
||||
(COMS
|
||||
(* ;; "Interlisp-D compatibility")
|
||||
|
||||
(FUNCTIONS INTERLISP-NAMESTRING UNPACKPATHNAME.STRING))
|
||||
(FUNCTIONS CL:FILE-NAMESTRING CL:DIRECTORY-NAMESTRING)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (%%INITIALIZE-DEFAULT-PATHNAME)))
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
(ADDVARS (NLAMA)
|
||||
(NLAML)
|
||||
(LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES
|
||||
PATHNAME %%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME])
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
|
||||
(ADDTOVAR NLAMA )
|
||||
|
||||
(ADDTOVAR NLAML )
|
||||
|
||||
(ADDTOVAR LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES PATHNAME
|
||||
%%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2012 2143 (%%WILD-NAME 2012 . 2143)) (2145 2224 (%%COMPONENT-STRING 2145 . 2224)) (2829
|
||||
8600 (%%PRINT-PATHNAME 2839 . 3000) (CL:MAKE-PATHNAME 3002 . 7752) (%%PRINT-DIRECTORY-COMPONENT 7754
|
||||
. 8598)) (8602 8795 (CL:PATHNAME-HOST 8602 . 8795)) (8797 8996 (CL:PATHNAME-DEVICE 8797 . 8996)) (
|
||||
8998 9206 (CL:PATHNAME-DIRECTORY 8998 . 9206)) (9208 9401 (CL:PATHNAME-NAME 9208 . 9401)) (9403 9596 (
|
||||
CL:PATHNAME-TYPE 9403 . 9596)) (9598 9800 (CL:PATHNAME-VERSION 9598 . 9800)) (9801 15390 (PATHNAME
|
||||
9811 . 10268) (CL:MERGE-PATHNAMES 10270 . 12356) (FILE-NAME 12358 . 12499) (CL:HOST-NAMESTRING 12501
|
||||
. 12690) (CL:ENOUGH-NAMESTRING 12692 . 15157) (%%NUMERIC-STRING-P 15159 . 15388)) (15392 19145 (
|
||||
CL:NAMESTRING 15392 . 19145)) (19147 22618 (CL:PARSE-NAMESTRING 19147 . 22618)) (22620 23623 (
|
||||
CL:TRUENAME 22620 . 23623)) (23625 23817 (%%MAKE-PATHNAME 23625 . 23817)) (23819 24456 (
|
||||
%%PATHNAME-EQUAL 23819 . 24456)) (24458 24915 (%%DIRECTORY-COMPONENT-EQUAL 24458 . 24915)) (24917
|
||||
25540 (%%INITIALIZE-DEFAULT-PATHNAME 24917 . 25540)) (25630 25797 (INTERLISP-NAMESTRING 25630 . 25797)
|
||||
) (25799 28692 (UNPACKPATHNAME.STRING 25799 . 28692)) (28694 29951 (CL:FILE-NAMESTRING 28694 . 29951))
|
||||
(29953 30151 (CL:DIRECTORY-NAMESTRING 29953 . 30151)))))
|
||||
(FILEMAP (NIL (1912 2043 (%%WILD-NAME 1912 . 2043)) (2045 2124 (%%COMPONENT-STRING 2045 . 2124)) (2729
|
||||
8653 (%%PRINT-PATHNAME 2739 . 3053) (CL:MAKE-PATHNAME 3055 . 7805) (%%PRINT-DIRECTORY-COMPONENT 7807
|
||||
. 8651)) (8655 8848 (CL:PATHNAME-HOST 8655 . 8848)) (8850 9049 (CL:PATHNAME-DEVICE 8850 . 9049)) (
|
||||
9051 9259 (CL:PATHNAME-DIRECTORY 9051 . 9259)) (9261 9454 (CL:PATHNAME-NAME 9261 . 9454)) (9456 9649 (
|
||||
CL:PATHNAME-TYPE 9456 . 9649)) (9651 9853 (CL:PATHNAME-VERSION 9651 . 9853)) (9854 15443 (PATHNAME
|
||||
9864 . 10321) (CL:MERGE-PATHNAMES 10323 . 12409) (FILE-NAME 12411 . 12552) (CL:HOST-NAMESTRING 12554
|
||||
. 12743) (CL:ENOUGH-NAMESTRING 12745 . 15210) (%%NUMERIC-STRING-P 15212 . 15441)) (15445 19198 (
|
||||
CL:NAMESTRING 15445 . 19198)) (19200 22671 (CL:PARSE-NAMESTRING 19200 . 22671)) (22673 23676 (
|
||||
CL:TRUENAME 22673 . 23676)) (23678 23870 (%%MAKE-PATHNAME 23678 . 23870)) (23872 24509 (
|
||||
%%PATHNAME-EQUAL 23872 . 24509)) (24511 24968 (%%DIRECTORY-COMPONENT-EQUAL 24511 . 24968)) (24970
|
||||
25593 (%%INITIALIZE-DEFAULT-PATHNAME 24970 . 25593)) (25683 25850 (INTERLISP-NAMESTRING 25683 . 25850)
|
||||
) (25852 28745 (UNPACKPATHNAME.STRING 25852 . 28745)) (28747 30004 (CL:FILE-NAMESTRING 28747 . 30004))
|
||||
(30006 30204 (CL:DIRECTORY-NAMESTRING 30006 . 30204)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@ -1,20 +1,21 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "13-Mar-95 12:41:10" {DSK}<lispcore>sources>CMLREADTABLE.;4 27688
|
||||
|
||||
changes to%: (FNS CMLREADSEMI)
|
||||
(FILECREATED "23-Mar-2024 22:05:12" {DSK}<home>larry>il>medley>sources>CMLREADTABLE.;2 27563
|
||||
|
||||
previous date%: "16-May-90 14:24:30" {DSK}<lispcore>sources>CMLREADTABLE.;1)
|
||||
:EDIT-BY "lmm"
|
||||
|
||||
:CHANGES-TO (VARS CMLREADTABLECOMS)
|
||||
(FUNCTIONS HASH-P)
|
||||
(FNS SET-DEFAULT-HASHMACRO-SETTINGS)
|
||||
|
||||
:PREVIOUS-DATE "13-Mar-95 12:41:10" {DSK}<home>larry>il>medley>sources>CMLREADTABLE.;1)
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1986, 1987, 1990, 1995 by Venue & Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT CMLREADTABLECOMS)
|
||||
|
||||
(RPAQQ CMLREADTABLECOMS
|
||||
((COMS (* ;
|
||||
"Common Lisp readtable interface functions ")
|
||||
"Common Lisp readtable interface functions ")
|
||||
(FUNCTIONS HASH-LEFT-PAD-INITIAL-CONTENTS CL:SET-SYNTAX-FROM-CHAR
|
||||
CL:GET-DISPATCH-MACRO-CHARACTER CL:GET-MACRO-CHARACTER
|
||||
CL:MAKE-DISPATCH-MACRO-CHARACTER CL:SET-DISPATCH-MACRO-CHARACTER
|
||||
@ -24,8 +25,8 @@ Copyright (c) 1986, 1987, 1990, 1995 by Venue & Xerox Corporation. All rights r
|
||||
(COMS (* ; "hash macro sub functions")
|
||||
(FUNCTIONS HASH-LEFTPAREN HASH-A HASH-B HASH-BACKSLASH HASH-C HASH-COLON HASH-COMMA
|
||||
HASH-DOT HASH-DOUBLEQUOTE HASH-ILLEGAL-HASH-CHAR HASH-LEFTANGLE HASH-MINUS
|
||||
HASH-NO-PARAMETER-ERROR HASH-O HASH-PLUS HASH-QUOTE HASH-R HASH-S HASH-STAR
|
||||
HASH-VBAR HASH-X HASH-EQUAL HASH-NUMBER-SIGN HASH-STRUCTURE-SMASH
|
||||
HASH-NO-PARAMETER-ERROR HASH-O HASH-P HASH-PLUS HASH-QUOTE HASH-R HASH-S
|
||||
HASH-STAR HASH-VBAR HASH-X HASH-EQUAL HASH-NUMBER-SIGN HASH-STRUCTURE-SMASH
|
||||
HASH-STRUCTURE-LOOKUP)
|
||||
(* ; "Temporary")
|
||||
(VARIABLES *READ-SUPPRESS*))
|
||||
@ -47,16 +48,14 @@ Copyright (c) 1986, 1987, 1990, 1995 by Venue & Xerox Corporation. All rights r
|
||||
(T (CL:ERROR "Values list too long for #~D()" SIZE])
|
||||
|
||||
(CL:DEFUN CL:SET-SYNTAX-FROM-CHAR (TO-CHAR FROM-CHAR &OPTIONAL (TO-READTABLE *READTABLE*)
|
||||
(FROM-READTABLE CMLRDTBL))
|
||||
(FROM-READTABLE CMLRDTBL))
|
||||
(SETSYNTAX (CL:CHAR-CODE TO-CHAR)
|
||||
(GETSYNTAX (CL:CHAR-CODE FROM-CHAR)
|
||||
FROM-READTABLE)
|
||||
TO-READTABLE))
|
||||
|
||||
(CL:DEFUN CL:GET-DISPATCH-MACRO-CHARACTER (DISP-CHAR SUB-CHAR &OPTIONAL (READTABLE *READTABLE*))
|
||||
[CDR (ASSOC SUB-CHAR (CDR (ASSOC DISP-CHAR (fetch (READTABLEP DISPATCHMACRODEFS) of
|
||||
READTABLE
|
||||
])
|
||||
[CDR (ASSOC SUB-CHAR (CDR (ASSOC DISP-CHAR (fetch (READTABLEP DISPATCHMACRODEFS) of READTABLE])
|
||||
|
||||
(CL:DEFUN CL:GET-MACRO-CHARACTER (CHAR &OPTIONAL (READTABLE *READTABLE*))
|
||||
|
||||
@ -77,8 +76,7 @@ Copyright (c) 1986, 1987, 1990, 1995 by Venue & Xerox Corporation. All rights r
|
||||
(CL:VALUES (FIND-MACRO-FUNCTION (CAR TABENTRY))
|
||||
(NEQ NON-TERMINATING-P 'ALWAYS])
|
||||
|
||||
(CL:DEFUN CL:MAKE-DISPATCH-MACRO-CHARACTER (CHAR &OPTIONAL NON-TERMINATING (READTABLE *READTABLE*
|
||||
))
|
||||
(CL:DEFUN CL:MAKE-DISPATCH-MACRO-CHARACTER (CHAR &OPTIONAL NON-TERMINATING (READTABLE *READTABLE*))
|
||||
(SETSYNTAX (CL:CHAR-CODE CHAR)
|
||||
`[MACRO ,(CL:IF NON-TERMINATING
|
||||
'FIRST
|
||||
@ -88,27 +86,25 @@ Copyright (c) 1986, 1987, 1990, 1995 by Venue & Xerox Corporation. All rights r
|
||||
READTABLE)
|
||||
T)
|
||||
|
||||
(CL:DEFUN CL:SET-DISPATCH-MACRO-CHARACTER (DISP-CHAR SUB-CHAR FUNCTION &OPTIONAL (READTABLE
|
||||
*READTABLE*))
|
||||
(CL:DEFUN CL:SET-DISPATCH-MACRO-CHARACTER (DISP-CHAR SUB-CHAR FUNCTION &OPTIONAL (READTABLE
|
||||
*READTABLE*))
|
||||
(CL:IF (CL:DIGIT-CHAR-P SUB-CHAR)
|
||||
(CL:ERROR "Digit ~S illegal as a sub-character for a dispatching macro" SUB-CHAR))
|
||||
(SETQ SUB-CHAR (CL:CHAR-UPCASE SUB-CHAR))
|
||||
(LET ((DISP-TABLE (OR (ASSOC DISP-CHAR (fetch (READTABLEP DISPATCHMACRODEFS) of READTABLE)
|
||||
)
|
||||
(LET ((DISP-TABLE (OR (ASSOC DISP-CHAR (fetch (READTABLEP DISPATCHMACRODEFS) of READTABLE))
|
||||
(LET ((NEWTABLE (LIST DISP-CHAR)))
|
||||
(push (fetch (READTABLEP DISPATCHMACRODEFS) of READTABLE)
|
||||
NEWTABLE)
|
||||
NEWTABLE)
|
||||
NEWTABLE)))
|
||||
DISP-CONS)
|
||||
(if (SETQ DISP-CONS (ASSOC SUB-CHAR (CDR DISP-TABLE)))
|
||||
then (CL:SETF (CDR DISP-CONS)
|
||||
FUNCTION)
|
||||
FUNCTION)
|
||||
else (push (CDR DISP-TABLE)
|
||||
(CONS SUB-CHAR FUNCTION)))
|
||||
(CONS SUB-CHAR FUNCTION)))
|
||||
T))
|
||||
|
||||
(CL:DEFUN CL:SET-MACRO-CHARACTER (CHAR FUNCTION &OPTIONAL NON-TERMINATING (READTABLE *READTABLE*)
|
||||
)
|
||||
(CL:DEFUN CL:SET-MACRO-CHARACTER (CHAR FUNCTION &OPTIONAL NON-TERMINATING (READTABLE *READTABLE*))
|
||||
(SETSYNTAX (CL:CHAR-CODE CHAR)
|
||||
`[MACRO ,(CL:IF NON-TERMINATING
|
||||
'FIRST
|
||||
@ -128,23 +124,23 @@ Copyright (c) 1986, 1987, 1990, 1995 by Venue & Xerox Corporation. All rights r
|
||||
((NOT DISP-TABLE)
|
||||
(CL:ERROR "~S is not a dispatch macro character" CHAR))
|
||||
(T (* ;
|
||||
"DISPATCHMACRODEFS is a list of A-lists")
|
||||
"DISPATCHMACRODEFS is a list of A-lists")
|
||||
[while (DIGITCHARP (SETQ NEXTCHAR (READCCODE STREAM RDTBL)))
|
||||
do (* ; "read the optional numeric arg")
|
||||
(SETQ INDEX (+ (TIMES (OR INDEX 0)
|
||||
10)
|
||||
(- NEXTCHAR (CHARCODE 0]
|
||||
do (* ; "read the optional numeric arg")
|
||||
(SETQ INDEX (+ (TIMES (OR INDEX 0)
|
||||
10)
|
||||
(- NEXTCHAR (CHARCODE 0]
|
||||
(LET* [(DISP-CHARACTER (CL:CHAR-UPCASE (CL:CODE-CHAR NEXTCHAR)))
|
||||
(DISP-FUNCTION (CDR (ASSOC DISP-CHARACTER DISP-TABLE]
|
||||
(if DISP-FUNCTION
|
||||
then (CL:FUNCALL DISP-FUNCTION STREAM DISP-CHARACTER INDEX)
|
||||
else (CL:IF *READ-SUPPRESS*
|
||||
(PROGN (* ; "Attempt to ignore it")
|
||||
(READ-EXTENDED-TOKEN STREAM *READTABLE* T)
|
||||
NIL)
|
||||
(CL:ERROR
|
||||
(PROGN (* ; "Attempt to ignore it")
|
||||
(READ-EXTENDED-TOKEN STREAM *READTABLE* T)
|
||||
NIL)
|
||||
(CL:ERROR
|
||||
"Undefined dispatch character ~S for dispatch macro character ~S"
|
||||
DISP-CHARACTER CHAR))])
|
||||
DISP-CHARACTER CHAR))])
|
||||
|
||||
(CL:DEFUN FIND-MACRO-FUNCTION (FORM)
|
||||
(COND
|
||||
@ -229,19 +225,19 @@ Copyright (c) 1986, 1987, 1990, 1995 by Venue & Xerox Corporation. All rights r
|
||||
(LIST '\, `(COERCE ,(LIST 'BQUOTE CONTENTS)
|
||||
'CL:VECTOR]
|
||||
(INDEX (IF (<= (LENGTH CONTENTS)
|
||||
INDEX)
|
||||
INDEX)
|
||||
THEN (LET [(VEC (CL:MAKE-ARRAY INDEX :INITIAL-ELEMENT (CAR (LAST CONTENTS]
|
||||
[LET ((XCL-USER::T0 (LENGTH CONTENTS))
|
||||
(I 0))
|
||||
(CL:BLOCK NIL
|
||||
(LET NIL (CL:TAGBODY LOOPTAG0015 (COND
|
||||
((>= I XCL-USER::T0)
|
||||
(RETURN NIL)))
|
||||
(CL:SETF (CL:AREF VEC I)
|
||||
(POP CONTENTS))
|
||||
(CL:INCF I)
|
||||
(GO LOOPTAG0015))))]
|
||||
VEC)
|
||||
[LET ((XCL-USER::T0 (LENGTH CONTENTS))
|
||||
(I 0))
|
||||
(CL:BLOCK NIL
|
||||
(LET NIL (CL:TAGBODY LOOPTAG0015 (COND
|
||||
((>= I XCL-USER::T0)
|
||||
(RETURN NIL)))
|
||||
(CL:SETF (CL:AREF VEC I)
|
||||
(POP CONTENTS))
|
||||
(CL:INCF I)
|
||||
(GO LOOPTAG0015))))]
|
||||
VEC)
|
||||
ELSE (CL:ERROR "Values list too long for #~D()" INDEX)))
|
||||
(T (CL:MAKE-ARRAY (LENGTH CONTENTS)
|
||||
:INITIAL-CONTENTS CONTENTS])
|
||||
@ -280,7 +276,7 @@ Copyright (c) 1986, 1987, 1990, 1995 by Venue & Xerox Corporation. All rights r
|
||||
(CL:READ STREAM T NIL T)
|
||||
(COMPLEX NUM DEN])
|
||||
|
||||
(CL:DEFUN HASH-COLON (STREAM CHAR PARAM) (* ; "Uninterned symbol.")
|
||||
(CL:DEFUN HASH-COLON (STREAM CHAR PARAM) (* ; "Uninterned symbol.")
|
||||
[COND
|
||||
(*READ-SUPPRESS* (READ-EXTENDED-TOKEN STREAM *READTABLE* T)
|
||||
NIL)
|
||||
@ -354,6 +350,9 @@ Copyright (c) 1986, 1987, 1990, 1995 by Venue & Xerox Corporation. All rights r
|
||||
(T (HASH-NO-PARAMETER-ERROR CHAR PARAM)
|
||||
(READNUMBERINBASE STREAM 8))))
|
||||
|
||||
(CL:DEFUN HASH-P (STREAM CHAR PARAM) (* ; "Edited 23-Mar-2024 22:01 by lmm")
|
||||
(PATHNAME (CL:READ STREAM T NIL T)))
|
||||
|
||||
(CL:DEFUN HASH-PLUS (STREAM CHAR PARAM)
|
||||
|
||||
(* ;; "When *READ-SUPPRESS* is true, we want to simply skip over the two forms (the feature expression and the controlled expression). Otherwise, we read the feature expression and, unless it applies to us, skip over the controlled expression. In any case, we never return a value.")
|
||||
@ -393,45 +392,45 @@ Copyright (c) 1986, 1987, 1990, 1995 by Venue & Xerox Corporation. All rights r
|
||||
(CL:DEFUN HASH-STAR (STREAM CHAR PARAM)
|
||||
(DECLARE (IGNORE CHAR))
|
||||
[IF (EQ (PEEKC STREAM)
|
||||
'%()
|
||||
THEN (* ; "It's a bitmap.")
|
||||
(IF *READ-SUPPRESS*
|
||||
THEN (CL:READ STREAM NIL NIL T)
|
||||
(CL:READ STREAM NIL NIL T)
|
||||
ELSEIF PARAM
|
||||
THEN (CL:ERROR "Unexpected parameter ~S given in #* bitmap syntax." PARAM)
|
||||
ELSE (FINISH-READING-BITMAP STREAM))
|
||||
ELSE (* ; "It's a bit-vector.")
|
||||
(LET* ((CONTENTS (READ-EXTENDED-TOKEN STREAM))
|
||||
(LEN (NCHARS CONTENTS)))
|
||||
(IF *READ-SUPPRESS*
|
||||
THEN NIL
|
||||
ELSEIF (AND (EQ LEN 0)
|
||||
PARAM
|
||||
(NEQ PARAM 0))
|
||||
THEN (CL:ERROR "No contents specified for bit vector #~A*" PARAM)
|
||||
ELSEIF (AND PARAM (> LEN PARAM))
|
||||
THEN (CL:ERROR "Bit vector contents longer than specified length in #~A*~A"
|
||||
PARAM CONTENTS)
|
||||
ELSE (LET [(BITARRAY (CL:MAKE-ARRAY (OR PARAM LEN)
|
||||
:ELEMENT-TYPE
|
||||
'BIT :INITIAL-ELEMENT
|
||||
(IF (AND PARAM (> PARAM LEN 0))
|
||||
THEN (SELCHARQ (NTHCHARCODE CONTENTS -1)
|
||||
(0 0)
|
||||
(1 1)
|
||||
(CL:ERROR
|
||||
'%()
|
||||
THEN (* ; "It's a bitmap.")
|
||||
(IF *READ-SUPPRESS*
|
||||
THEN (CL:READ STREAM NIL NIL T)
|
||||
(CL:READ STREAM NIL NIL T)
|
||||
ELSEIF PARAM
|
||||
THEN (CL:ERROR "Unexpected parameter ~S given in #* bitmap syntax." PARAM)
|
||||
ELSE (FINISH-READING-BITMAP STREAM))
|
||||
ELSE (* ; "It's a bit-vector.")
|
||||
(LET* ((CONTENTS (READ-EXTENDED-TOKEN STREAM))
|
||||
(LEN (NCHARS CONTENTS)))
|
||||
(IF *READ-SUPPRESS*
|
||||
THEN NIL
|
||||
ELSEIF (AND (EQ LEN 0)
|
||||
PARAM
|
||||
(NEQ PARAM 0))
|
||||
THEN (CL:ERROR "No contents specified for bit vector #~A*" PARAM)
|
||||
ELSEIF (AND PARAM (> LEN PARAM))
|
||||
THEN (CL:ERROR "Bit vector contents longer than specified length in #~A*~A" PARAM
|
||||
CONTENTS)
|
||||
ELSE (LET [(BITARRAY (CL:MAKE-ARRAY (OR PARAM LEN)
|
||||
:ELEMENT-TYPE
|
||||
'BIT :INITIAL-ELEMENT
|
||||
(IF (AND PARAM (> PARAM LEN 0))
|
||||
THEN (SELCHARQ (NTHCHARCODE CONTENTS -1)
|
||||
(0 0)
|
||||
(1 1)
|
||||
(CL:ERROR
|
||||
"Illegal bit vector element in #~A*~A"
|
||||
PARAM CONTENTS))
|
||||
ELSE 0]
|
||||
(CL:DOTIMES (I LEN)
|
||||
(CL:SETF (CL:AREF BITARRAY I)
|
||||
(SELCHARQ (NTHCHARCODE CONTENTS (CL:1+ I))
|
||||
(0 0)
|
||||
(1 1)
|
||||
(CL:ERROR "Illegal bit vector element in #~A*~A"
|
||||
PARAM CONTENTS))))
|
||||
BITARRAY])
|
||||
PARAM CONTENTS))
|
||||
ELSE 0]
|
||||
(CL:DOTIMES (I LEN)
|
||||
(CL:SETF (CL:AREF BITARRAY I)
|
||||
(SELCHARQ (NTHCHARCODE CONTENTS (CL:1+ I))
|
||||
(0 0)
|
||||
(1 1)
|
||||
(CL:ERROR "Illegal bit vector element in #~A*~A" PARAM
|
||||
CONTENTS))))
|
||||
BITARRAY])
|
||||
|
||||
(CL:DEFUN HASH-VBAR (STREAM CHAR PARAM)
|
||||
(OR *READ-SUPPRESS* (HASH-NO-PARAMETER-ERROR CHAR PARAM))
|
||||
@ -575,30 +574,32 @@ Copyright (c) 1986, 1987, 1990, 1995 by Venue & Xerox Corporation. All rights r
|
||||
NIL READ-LINE-RDTBL])
|
||||
|
||||
(SET-DEFAULT-HASHMACRO-SETTINGS
|
||||
[LAMBDA (RDTBL) (* jrb%: "10-Nov-86 15:46")
|
||||
[LAMBDA (RDTBL) (* ; "Edited 23-Mar-2024 21:57 by lmm")
|
||||
(* jrb%: "10-Nov-86 15:46")
|
||||
(READTABLEPROP RDTBL 'HASHMACROCHAR (CHARCODE "#"))
|
||||
(CL:MAKE-DISPATCH-MACRO-CHARACTER #\# T RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\( 'HASH-LEFTPAREN RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\' 'HASH-QUOTE RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\. 'HASH-DOT RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\, 'HASH-COMMA RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\\ 'HASH-BACKSLASH RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\* 'HASH-STAR RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\: 'HASH-COLON RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\O 'HASH-O RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\B 'HASH-B RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\X 'HASH-X RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\R 'HASH-R RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\A 'HASH-A RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\S 'HASH-S RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\C 'HASH-C RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\+ 'HASH-PLUS RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\- 'HASH-MINUS RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\| 'HASH-VBAR RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\< 'HASH-LEFTANGLE RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\" 'HASH-DOUBLEQUOTE RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\= 'HASH-EQUAL RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\# 'HASH-NUMBER-SIGN RDTBL)
|
||||
(CL:MAKE-DISPATCH-MACRO-CHARACTER #\# T RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\( 'HASH-LEFTPAREN RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\' 'HASH-QUOTE RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\. 'HASH-DOT RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\, 'HASH-COMMA RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\\ 'HASH-BACKSLASH RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\* 'HASH-STAR RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\: 'HASH-COLON RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\O 'HASH-O RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\B 'HASH-B RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\X 'HASH-X RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\R 'HASH-R RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\A 'HASH-A RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\S 'HASH-S RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\C 'HASH-C RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\P 'HASH-P RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\+ 'HASH-PLUS RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\- 'HASH-MINUS RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\| 'HASH-VBAR RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\< 'HASH-LEFTANGLE RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\" 'HASH-DOUBLEQUOTE RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\= 'HASH-EQUAL RDTBL)
|
||||
(CL:SET-DISPATCH-MACRO-CHARACTER #\# #\# 'HASH-NUMBER-SIGN RDTBL)
|
||||
RDTBL])
|
||||
|
||||
(CMLREADSEMI
|
||||
@ -617,8 +618,26 @@ Copyright (c) 1986, 1987, 1990, 1995 by Venue & Xerox Corporation. All rights r
|
||||
)
|
||||
|
||||
(PUTPROPS CMLREADTABLE FILETYPE CL:COMPILE-FILE)
|
||||
(PUTPROPS CMLREADTABLE COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1995))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (22724 27461 (CMLRDTBL 22734 . 24394) (INIT-CML-READTABLES 24396 . 25532) (
|
||||
SET-DEFAULT-HASHMACRO-SETTINGS 25534 . 27112) (CMLREADSEMI 27114 . 27459)))))
|
||||
(FILEMAP (NIL (2167 2474 (HASH-LEFT-PAD-INITIAL-CONTENTS 2167 . 2474)) (2476 2778 (
|
||||
CL:SET-SYNTAX-FROM-CHAR 2476 . 2778)) (2780 2987 (CL:GET-DISPATCH-MACRO-CHARACTER 2780 . 2987)) (2989
|
||||
3795 (CL:GET-MACRO-CHARACTER 2989 . 3795)) (3797 4179 (CL:MAKE-DISPATCH-MACRO-CHARACTER 3797 . 4179))
|
||||
(4181 5178 (CL:SET-DISPATCH-MACRO-CHARACTER 4181 . 5178)) (5180 5643 (CL:SET-MACRO-CHARACTER 5180 .
|
||||
5643)) (5645 7242 (DO-DISPATCH-MACRO 5645 . 7242)) (7244 7427 (FIND-MACRO-FUNCTION 7244 . 7427)) (7429
|
||||
7852 (CL-MACRO-WRAPPED-P 7429 . 7852)) (7854 7986 (CL-UNWRAP-MACRO 7854 . 7986)) (7988 8197 (
|
||||
CL-WRAP-MACRO 7988 . 8197)) (8199 8675 (IL-MACRO-WRAPPED-P 8199 . 8675)) (8677 8744 (IL-UNWRAP-MACRO
|
||||
8677 . 8744)) (8746 8941 (IL-WRAP-MACRO 8746 . 8941)) (8984 10755 (HASH-LEFTPAREN 8984 . 10755)) (
|
||||
10757 11010 (HASH-A 10757 . 11010)) (11012 11235 (HASH-B 11012 . 11235)) (11237 11641 (HASH-BACKSLASH
|
||||
11237 . 11641)) (11643 11923 (HASH-C 11643 . 11923)) (11925 12232 (HASH-COLON 11925 . 12232)) (12234
|
||||
12911 (HASH-COMMA 12234 . 12911)) (12913 13259 (HASH-DOT 12913 . 13259)) (13261 13618 (
|
||||
HASH-DOUBLEQUOTE 13261 . 13618)) (13620 13730 (HASH-ILLEGAL-HASH-CHAR 13620 . 13730)) (13732 13890 (
|
||||
HASH-LEFTANGLE 13732 . 13890)) (13892 14709 (HASH-MINUS 13892 . 14709)) (14711 14849 (
|
||||
HASH-NO-PARAMETER-ERROR 14711 . 14849)) (14851 15074 (HASH-O 14851 . 15074)) (15076 15228 (HASH-P
|
||||
15076 . 15228)) (15230 16052 (HASH-PLUS 15230 . 16052)) (16054 16277 (HASH-QUOTE 16054 . 16277)) (
|
||||
16279 16507 (HASH-R 16279 . 16507)) (16509 16727 (HASH-S 16509 . 16727)) (16729 19267 (HASH-STAR 16729
|
||||
. 19267)) (19269 19476 (HASH-VBAR 19269 . 19476)) (19478 19702 (HASH-X 19478 . 19702)) (19704 20200 (
|
||||
HASH-EQUAL 19704 . 20200)) (20202 20474 (HASH-NUMBER-SIGN 20202 . 20474)) (20476 22174 (
|
||||
HASH-STRUCTURE-SMASH 20476 . 22174)) (22176 22307 (HASH-STRUCTURE-LOOKUP 22176 . 22307)) (22418 27420
|
||||
(CMLRDTBL 22428 . 24088) (INIT-CML-READTABLES 24090 . 25226) (SET-DEFAULT-HASHMACRO-SETTINGS 25228 .
|
||||
27071) (CMLREADSEMI 27073 . 27418)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Loading…
x
Reference in New Issue
Block a user