Changeset 8467


Ignore:
Timestamp:
02/05/05 17:47:23 (17 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

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

    r4513 r8467  
    11;;; defsetf.lisp
    22;;;
    3 ;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: defsetf.lisp,v 1.1 2003-10-23 13:16:36 piso Exp $
     3;;; Copyright (C) 2003-2005 Peter Graves
     4;;; $Id: defsetf.lisp,v 1.2 2005-02-05 17:47:23 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    1818;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
    1919
    20 ;;; CURRENTLY THIS FILE IS NOT USED! Oct 23 2003 6:16 AM
     20;;; Adapted from SBCL.
    2121
    22 (in-package "SYSTEM")
     22(in-package #:system)
    2323
    24 (require :collect)
    25 
    26 ;; (defmacro defsetf (access-function update-function)
    27 ;;   `(%put ',access-function 'setf-inverse ',update-function))
     24(require '#:collect)
    2825
    2926(defun %define-setf-macro (name expander inverse doc)
    30 ;;   (cond ((not (fboundp `(setf ,name))))
    31 ;;  ((info function accessor-for name)
    32 ;;   (warn "Defining setf macro for destruct slot accessor; redefining as ~
    33 ;;          a normal function:~%  ~S"
    34 ;;         name)
    35 ;;   (c::define-function-name name))
    36 ;;  ((not (eq (symbol-package name) (symbol-package 'aref)))
    37 ;;   (warn "Defining setf macro for ~S, but ~S is fbound."
    38 ;;         name `(setf ,name))))
    39 ;;   (when (or inverse (info setf inverse name))
    40 ;;     (setf (info setf inverse name) inverse))
    41 ;;   (when (or expander (info setf expander name))
    42 ;;     (setf (info setf expander name) expander))
    43 ;;   (when doc
    44 ;;     (setf (documentation name 'setf) doc))
    4527  (when inverse
    4628    (setf (get name 'setf-inverse) inverse))
     
    6850(defmacro defsetf (access-fn &rest rest)
    6951  (cond ((not (listp (car rest)))
    70    `(eval-when (load compile eval)
     52   `(eval-when (:load-toplevel :compile-toplevel :execute)
    7153      (%define-setf-macro ',access-fn nil ',(car rest)
    7254        ,(when (and (car rest) (stringp (cadr rest)))
     
    8466                              arglist-var body access-fn 'defsetf
    8567                              :anonymousp t)
    86               `(eval-when (load compile eval)
     68              `(eval-when (:load-toplevel :compile-toplevel :execute)
    8769                 (%define-setf-macro
    8870                  ',access-fn
     
    9678                  ',doc))))))
    9779  (t
    98    (error "ill-formed DEFSETF for ~S" access-fn))))
     80   (error "Ill-formed DEFSETF for ~S" access-fn))))
Note: See TracChangeset for help on using the changeset viewer.