source: trunk/abcl/src/org/armedbear/lisp/ldb.lisp @ 14215

Last change on this file since 14215 was 11391, checked in by vvoutilainen, 12 years ago

ABCL license is GPL + Classpath exception. This was intended
by Peter Graves, the original author. For reference, see
http://sourceforge.net/mailarchive/forum.php?thread_name=20040721115302.839%40prufrock&forum_name=armedbear-j-announce

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 3.6 KB
Line 
1;;; ldb.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: ldb.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package #:system)
33
34(defun byte (size position)
35  (cons size position))
36
37(defun byte-size (bytespec)
38  (car bytespec))
39
40(defun byte-position (bytespec)
41  (cdr bytespec))
42
43(defun ldb (bytespec integer)
44  (logand (ash integer (- (byte-position bytespec)))
45          (1- (ash 1 (byte-size bytespec)))))
46
47(defun ldb-test (bytespec integer)
48  (not (zerop (ldb bytespec integer))))
49
50(defun dpb (newbyte bytespec integer)
51  (let* ((size (byte-size bytespec))
52         (position (byte-position bytespec))
53         (mask (1- (ash 1 size))))
54    (logior (logand integer (lognot (ash mask position)))
55      (ash (logand newbyte mask) position))))
56
57;; From SBCL.
58(define-setf-expander ldb (bytespec place &environment env)
59  (multiple-value-bind (dummies vals newval setter getter)
60    (get-setf-expansion place env)
61    (if (and (consp bytespec) (eq (car bytespec) 'byte))
62  (let ((n-size (gensym))
63        (n-pos (gensym))
64        (n-new (gensym)))
65    (values (list* n-size n-pos dummies)
66      (list* (second bytespec) (third bytespec) vals)
67      (list n-new)
68      `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos)
69               ,getter)))
70         ,setter
71         ,n-new)
72      `(ldb (byte ,n-size ,n-pos) ,getter)))
73  (let ((btemp (gensym))
74        (gnuval (gensym)))
75    (values (cons btemp dummies)
76      (cons bytespec vals)
77      (list gnuval)
78      `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter)))
79         ,setter
80         ,gnuval)
81      `(ldb ,btemp ,getter))))))
82
83;; Used by the LDB source transform.
84(defun %ldb (size position integer)
85  (logand (ash integer (- position))
86    (1- (ash 1 size))))
87
88(define-setf-expander %ldb (size position place &environment env)
89  (multiple-value-bind (dummies vals newval setter getter)
90      (get-setf-expansion place env)
91    (let ((n-size (gensym))
92          (n-pos (gensym))
93          (n-new (gensym)))
94      (values (list* n-size n-pos dummies)
95              (list* size position vals)
96              (list n-new)
97              `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos)
98                                         ,getter)))
99                 ,setter
100                 ,n-new)
101              `(ldb (byte ,n-size ,n-pos) ,getter)))))
Note: See TracBrowser for help on using the repository browser.