Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 122 lines (105 sloc) 5.032 kb
c236684f » hanshuebner
2004-06-23 Initial revision
1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-INTERPOL; Base: 10 -*-
d0c8d83b » Edi Weitz
2008-07-23 Update to dev version
2 ;;; $Header: /usr/local/cvsrep/cl-interpol/util.lisp,v 1.12 2008/07/23 14:41:37 edi Exp $
c236684f » hanshuebner
2004-06-23 Initial revision
3
d0c8d83b » Edi Weitz
2008-07-23 Update to dev version
4 ;;; Copyright (c) 2003-2008, Dr. Edmund Weitz. All rights reserved.
c236684f » hanshuebner
2004-06-23 Initial revision
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
d0c8d83b » Edi Weitz
2008-07-23 Update to dev version
30 (in-package :cl-interpol)
c236684f » hanshuebner
2004-06-23 Initial revision
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."
d0c8d83b » Edi Weitz
2008-07-23 Update to dev version
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
c236684f » hanshuebner
2004-06-23 Initial revision
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
61 START-DELIMITER in a list DELIMITERS which is formatted like
62 *OUTER-DELIMITERS*. If ERRORP is true, signal an error if none was
63 found, 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
76 VECTOR-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
85 interpreted 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
101 the 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
106 the 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
112 INTERPOL-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))
Something went wrong with that request. Please try again.