Ignore:
Timestamp:
02/28/04 19:08:56 (19 years ago)
Author:
piso
Message:

SETF LDB

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/ldb.lisp

    r6041 r6043  
    22;;;
    33;;; Copyright (C) 2003-2004 Peter Graves
    4 ;;; $Id: ldb.lisp,v 1.3 2004-02-28 18:40:08 piso Exp $
     4;;; $Id: ldb.lisp,v 1.4 2004-02-28 19:08:56 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    4747    (logior (logand integer (lognot (ash mask position)))
    4848      (ash (logand newbyte mask) position))))
     49
     50;; From SBCL.
     51(define-setf-expander ldb (bytespec place &environment env)
     52  (multiple-value-bind (dummies vals newval setter getter)
     53    (get-setf-expansion place env)
     54    (if (and (consp bytespec) (eq (car bytespec) 'byte))
     55  (let ((n-size (gensym))
     56        (n-pos (gensym))
     57        (n-new (gensym)))
     58    (values (list* n-size n-pos dummies)
     59      (list* (second bytespec) (third bytespec) vals)
     60      (list n-new)
     61      `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos)
     62               ,getter)))
     63         ,setter
     64         ,n-new)
     65      `(ldb (byte ,n-size ,n-pos) ,getter)))
     66  (let ((btemp (gensym))
     67        (gnuval (gensym)))
     68    (values (cons btemp dummies)
     69      (cons bytespec vals)
     70      (list gnuval)
     71      `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter)))
     72         ,setter
     73         ,gnuval)
     74      `(ldb ,btemp ,getter))))))
Note: See TracChangeset for help on using the changeset viewer.