1;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-INTERPOL; Base: 10 -*- 2;;; $Header: /usr/local/cvsrep/cl-interpol/util.lisp,v 1.12 2008/07/23 14:41:37 edi Exp $ 3 4;;; Copyright (c) 2003-2008, Dr. Edmund Weitz. All rights reserved. 5 6;;; Redistribution and use in source and binary forms, with or without 7;;; modification, are permitted provided that the following conditions 8;;; are met: 9 10;;; * Redistributions of source code must retain the above copyright 11;;; notice, this list of conditions and the following disclaimer. 12 13;;; * Redistributions in binary form must reproduce the above 14;;; copyright notice, this list of conditions and the following 15;;; disclaimer in the documentation and/or other materials 16;;; provided with the distribution. 17 18;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 19;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 22;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 24;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 25;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 26;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 30(in-package :cl-interpol) 31 32(define-condition simple-reader-error (simple-condition reader-error) 33 () 34 (:documentation "A reader error which can be signalled by ERROR.")) 35 36(defmacro signal-reader-error (format-control &rest format-arguments) 37 "Like ERROR but signals a SIMPLE-READER-ERROR for the stream 38*STREAM*." 39 `(error 'simple-reader-error 40 :stream *stream* 41 :format-control ,format-control 42 :format-arguments (list ,@format-arguments))) 43 44(defun string-list-to-string (string-list) 45 "Concatenates a list of strings to one string." 46 ;; this function was originally provided by JP Massar for CL-PPCRE; 47 ;; note that we can't use APPLY with CONCATENATE here because of 48 ;; CALL-ARGUMENTS-LIMIT 49 (let ((total-size 0)) 50 (dolist (string string-list) 51 (incf total-size (length string))) 52 (let ((result-string (make-array total-size :element-type 'character)) 53 (curr-pos 0)) 54 (dolist (string string-list) 55 (replace result-string string :start1 curr-pos) 56 (incf curr-pos (length string))) 57 result-string))) 58 59(defun get-end-delimiter (start-delimiter delimiters &key errorp) 60 "Find the closing delimiter corresponding to the opening delimiter 61START-DELIMITER in a list DELIMITERS which is formatted like 62*OUTER-DELIMITERS*. If ERRORP is true, signal an error if none was 63found, otherwise return NIL." 64 (loop for element in delimiters 65 if (eql start-delimiter element) 66 do (return-from get-end-delimiter start-delimiter) 67 else if (and (consp element) 68 (char= start-delimiter (car element))) 69 do (return-from get-end-delimiter (cdr element))) 70 (when errorp 71 (signal-reader-error "~S not allowed as a delimiter here" start-delimiter))) 72 73(declaim (inline make-collector)) 74(defun make-collector () 75 "Create an empty string which can be extended by 76VECTOR-PUSH-EXTEND." 77 (make-array 0 78 :element-type 'character 79 :fill-pointer t 80 :adjustable t)) 81 82(declaim (inline make-char-from-code)) 83(defun make-char-from-code (number) 84 "Create character from char-code NUMBER. NUMBER can be NIL which is 85interpreted as 0." 86 ;; Only look at rightmost eight bits in compliance with Perl 87 (let ((code (logand #o377 (or number 0)))) 88 (or (and (< code char-code-limit) 89 (code-char code)) 90 (signal-reader-error "No character for char-code #x~X" 91 number)))) 92 93(declaim (inline lower-case-p*)) 94(defun lower-case-p* (char) 95 "Whether CHAR is a character which has case and is lowercase." 96 (or (not (both-case-p char)) 97 (lower-case-p char))) 98 99(defmacro read-char* () 100 "Convenience macro because we always read from the same string with 101the same arguments." 102 `(read-char *stream* t nil t)) 103 104(defmacro peek-char* () 105 "Convenience macro because we always peek at the same string with 106the same arguments." 107 `(peek-char nil *stream* t nil t)) 108 109(declaim (inline copy-readtable*)) 110(defun copy-readtable* () 111 "Returns a copy of the readtable which was current when 112INTERPOL-READER was invoked. Memoizes its result." 113 (or *readtable-copy* 114 (setq *readtable-copy* (copy-readtable)))) 115 116(declaim (inline nsubvec)) 117(defun nsubvec (sequence start &optional (end (length sequence))) 118 "Return a subvector by pointing to location in original vector." 119 (make-array (- end start) 120 :element-type (array-element-type sequence) 121 :displaced-to sequence 122 :displaced-index-offset start)) 123