/[cl-carbon]/CL-Carbon/utils.lisp
ViewVC logotype

Contents of /CL-Carbon/utils.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Sat May 21 07:27:21 2005 UTC (8 years, 10 months ago) by dsteuber
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +10 -12 lines
Fixed macros in utils.lisp that were using FFI reader macros with side
effects.  This bug showed up as undeclared free variables that are created
by the #$ reader macros.  I also made some utility functions for the #_
reader macro functions being used in utils.lisp macros.  This should allow
dfsl files to work properly when loaded into an image even though they
were created during a different lisp session.

I also did some package exports cleanup.  Instead of using EXPORT in
utils.lisp, I moved the exported symbols to the :exports section of the
DEFPACKAGE form in package.lisp.  At some point, those exports probably
should be sorted into alphabetical order.

I tested these chages with Example which I have not made any changes to.
Example symlinks in CL-Carbon, so the make script can't remove dfsl files
built when making CL-Carbon which was hiding the bug from me.  Example
still seems to work.  It just needs to use more of CL-Carbon :-).
1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: CL-CARBON -*-
2 ;;;; ***********************************************************************
3 ;;;; FILE IDENTIFICATION
4 ;;;;
5 ;;;; Name: utils.lisp
6 ;;;; Project: CL-Carbon
7 ;;;; Purpose: Utility macros and functions
8 ;;;; Programmer: David Steuber
9 ;;;; Date Started: 1/21/2005
10 ;;;;
11 ;;;; $Id: utils.lisp,v 1.2 2005/05/21 07:27:21 dsteuber Exp $
12 ;;;; ***********************************************************************
13 ;;;;
14 ;;;; Copyright (c) 2005 by David Steuber
15 ;;;;
16 ;;;; Permission is hereby granted, free of charge, to any person obtaining
17 ;;;; a copy of this software and associated documentation files (the
18 ;;;; "Software"), to deal in the Software without restriction, including
19 ;;;; without limitation the rights to use, copy, modify, merge, publish,
20 ;;;; distribute, sublicense, and/or sell copies of the Software, and to
21 ;;;; permit persons to whom the Software is furnished to do so, subject to
22 ;;;; the following conditions:
23 ;;;;
24 ;;;; The above copyright notice and this permission notice shall be
25 ;;;; included in all copies or substantial portions of the Software.
26 ;;;;
27 ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
28 ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
29 ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
30 ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
31 ;;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
32 ;;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
33 ;;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
34 ;;;;
35 ;;;; ***********************************************************************
36
37 (in-package :cl-carbon)
38
39 (defun cf-string-make-constant-string (s)
40 (#___CFStringMakeConstantString s))
41
42 (defmacro const-cfstring (str)
43 (let ((s (gensym)))
44 `(ccl::with-cstr (,s ,str) (cl-carbon::cf-string-make-constant-string ,s))))
45
46 (defun make-cfstring (str)
47 "Allocates a CFString object stored in a MACPTR which must be
48 CFRelease(d) when no longer needed."
49 (ccl::with-cstr (cstr str)
50 (#_CFStringCreateWithCString (ccl:%null-ptr) cstr #$kCFStringEncodingMacRoman)))
51
52 (defun cf-release (cf-ptr)
53 (#_CFRelease cf-ptr))
54
55 (defmacro with-cfstring ((sym str) &rest body)
56 "Create, use, and then release a CFString."
57 `(let ((,sym (make-cfstring ,str)))
58 (unwind-protect (progn ,@body)
59 (cl-carbon::cf-release ,sym))))
60
61 (defmacro with-cfstrings (speclist &body body)
62 "Create, use, and then release CFStrings."
63 (ccl::with-specs-aux 'with-cfstring speclist body))
64
65 (defmacro require-noerror (&body forms)
66 (let* ((err (gensym))
67 (body (reverse `(let (,err)))))
68 (dolist (form forms (nreverse body))
69 (push `(setf ,err ,form) body)
70 (push `(assert (eql ,err #.#.(read-from-string "#$noErr"))) body))))
71
72 (defmacro case-equal (exp &body clauses)
73 (let ((temp (gensym)))
74 `(let ((,temp ,exp))
75 (cond ,@(mapcar #'(lambda (clause)
76 (destructuring-bind (keys . clause-forms) clause
77 (if (eq keys 'otherwise)
78 `(t ,@clause-forms)
79 (if (atom keys)
80 `((equal ,temp ,keys) ,@clause-forms)
81 `((member ,temp ',keys :test #'equal)
82 ,@clause-forms)))))
83 clauses)))))
84
85 (defun show-alert (s)
86 (ccl::with-pstr (message-str s)
87 (#_StandardAlert #$kAlertNoteAlert message-str (%null-ptr) (%null-ptr) (%null-ptr))))
88
89 (defun make-lisp-string-from-cfstringref (ptr &optional (encoding #$kCFStringEncodingMacRoman))
90 "Use the CFStringRef in ptr to make a Lisp string useing the provided encoding."
91 (rlet ((cstr (:* :char) (#_CFStringGetCStringPtr ptr encoding)))
92 (if (ccl::%null-ptr-p cstr)
93 (rlet ((buffer (:array :char 1024)))
94 (when (= 1 (#_CFStringGetCString ptr buffer 1024 encoding))
95 (ccl::%get-cstring buffer)))
96 (ccl::%get-cstring (ccl::%get-ptr cstr)))))

  ViewVC Help
Powered by ViewVC 1.1.5