source: branches/qres/ccl/library/pascal-strings.lisp @ 15278

Last change on this file since 15278 was 13070, checked in by gz, 10 years ago

r13066, r13067 from trunk: copyrights etc

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 3.7 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2003-2009 Clozure Associates
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17
18;;; Utilities for dealing with Pascal strings
19;;;
20;;; In 68K Mac Pascal, strings were represented by a pointer to a
21;;; "length byte", which indicated the number of data bytes immediately
22;;; following.
23
24(in-package "CCL")
25
26(eval-when (:compile-toplevel :load-toplevel :execute)
27  ;; What else should be exported ?  What else should be added
28  ;; to this file ?
29  (export '(with-pstrs with-returned-pstrs %get-string)))
30
31(defun %pstr-pointer (string pointer)
32  (multiple-value-bind (s o n) (dereference-base-string string)
33    (declare (fixnum o n))
34    (%copy-ivector-to-ptr s o pointer 1 n)
35    (setf (%get-byte pointer 0) n))
36  nil)
37
38(defun %pstr-segment-pointer (string pointer start end)
39  (declare (fixnum start end))
40  (let* ((n (- end start)))
41    (multiple-value-bind (s o) (dereference-base-string string)
42      (declare (fixnum o))
43      (%copy-ivector-to-ptr s (the fixnum (+ o start)) pointer 1 n)
44    (setf (%get-byte pointer 0) n)
45    nil)))
46
47(defun %get-string (pointer)
48  (let* ((len (%get-unsigned-byte pointer)))
49    (%copy-ptr-to-ivector
50     pointer
51     1
52     (make-string len :element-type 'base-char)
53     0
54     len)))
55
56(defun (setf %get-string) (lisp-string pointer)
57  (let* ((len (length lisp-string)))
58    (multiple-value-bind (string offset)
59        (dereference-base-string lisp-string)
60      (setf (%get-unsigned-byte pointer) len)
61      (%copy-ivector-to-ptr string offset pointer 1 len))
62    lisp-string))
63
64(defmacro with-pstr ((sym str &optional start end) &rest body &environment env)
65  (multiple-value-bind (body decls) (parse-body body env nil)
66    (if (and (base-string-p str) (null start) (null end))
67      (let ((strlen (%i+ (length str) 1)))
68        `(%stack-block ((,sym ,strlen))
69           ,@decls
70           (%pstr-pointer ,str ,sym)
71           ,@body))
72      (let ((strname (gensym))
73            (start-name (gensym))
74            (end-name (gensym)))
75        `(let ((,strname ,str)
76               ,@(if (or start end)
77                   `((,start-name ,(or start 0))
78                     (,end-name ,(or end `(length ,strname))))))
79           (%vstack-block (,sym
80                           (the fixnum
81                             (1+
82                              (the fixnum
83                                ,(if (or start end)
84                                     `(byte-length
85                                       ,strname ,start-name ,end-name)
86                                     `(length ,strname))))))
87             ,@decls
88             ,(if (or start end)
89                `(%pstr-segment-pointer ,strname ,sym ,start-name ,end-name)
90                `(%pstr-pointer ,strname ,sym))
91             ,@body))))))
92
93
94(defmacro with-returned-pstr ((sym str &optional start end) &body body)
95   `(%stack-block ((,sym 256))
96      ,(if (or start end)
97         `(%pstr-segment-pointer ,str ,sym ,start ,end)
98         `(%pstr-pointer ,str ,sym))
99      ,@body))
100
101(defmacro with-pstrs (speclist &body body)
102   (with-specs-aux 'with-pstr speclist body))
103
104(defmacro with-returned-pstrs (speclist &body body)
105   (with-specs-aux 'with-returned-pstr speclist body))
106
107
Note: See TracBrowser for help on using the repository browser.