From a5dfb70307cb6fd93263e155309038a2229ff6a1 Mon Sep 17 00:00:00 2001 From: =?utf8?q?David=20V=C3=A1zquez?= Date: Sun, 5 May 2013 16:20:36 +0100 Subject: [PATCH] Move DEF!STRUCT to defstruct.lisp --- jscl.lisp | 24 +++++++++--------- src/compiler.lisp | 56 ------------------------------------------ src/defstruct.lisp | 69 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 82 insertions(+), 67 deletions(-) create mode 100644 src/defstruct.lisp diff --git a/jscl.lisp b/jscl.lisp index 76d2c84..47899f0 100644 --- a/jscl.lisp +++ b/jscl.lisp @@ -23,17 +23,19 @@ (in-package :jscl) (defvar *source* - '(("boot" :target) - ("compat" :host) - ("utils" :both) - ("list" :target) - ("string" :target) - ("print" :target) - ("package" :target) - ("ffi" :target) - ("read" :both) - ("compiler" :both) - ("toplevel" :target))) + '(("boot" :target) + ("compat" :host) + ("utils" :both) + ("list" :target) + ("string" :target) + ("print" :target) + ("package" :target) + ("ffi" :target) + ("read" :both) + ("defstruct" :both) + ("lambda-list" :both) + ("compiler" :both) + ("toplevel" :target))) (defun source-pathname (filename &key (directory '(:relative "src")) (type nil) (defaults filename)) diff --git a/src/compiler.lisp b/src/compiler.lisp index 8421b16..3dc2f1c 100644 --- a/src/compiler.lisp +++ b/src/compiler.lisp @@ -87,62 +87,6 @@ ;;; function call. (defvar *multiple-value-p* nil) -;; A very simple defstruct built on lists. It supports just slot with -;; an optional default initform, and it will create a constructor, -;; predicate and accessors for you. -(defmacro def!struct (name &rest slots) - (unless (symbolp name) - (error "It is not a full defstruct implementation.")) - (let* ((name-string (symbol-name name)) - (slot-descriptions - (mapcar (lambda (sd) - (cond - ((symbolp sd) - (list sd)) - ((and (listp sd) (car sd) (cddr sd)) - sd) - (t - (error "Bad slot description `~S'." sd)))) - slots)) - (predicate (intern (concat name-string "-P")))) - `(progn - ;; Constructor - (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions) - (list ',name ,@(mapcar #'car slot-descriptions))) - ;; Predicate - (defun ,predicate (x) - (and (consp x) (eq (car x) ',name))) - ;; Copier - (defun ,(intern (concat "COPY-" name-string)) (x) - (copy-list x)) - ;; Slot accessors - ,@(with-collect - (let ((index 1)) - (dolist (slot slot-descriptions) - (let* ((name (car slot)) - (accessor-name (intern (concat name-string "-" (string name))))) - (collect - `(defun ,accessor-name (x) - (unless (,predicate x) - (error "The object `~S' is not of type `~S'" x ,name-string)) - (nth ,index x))) - ;; TODO: Implement this with a higher level - ;; abstraction like defsetf or (defun (setf ..)) - (collect - `(define-setf-expander ,accessor-name (x) - (let ((object (gensym)) - (new-value (gensym))) - (values (list object) - (list x) - (list new-value) - `(progn - (rplaca (nthcdr ,',index ,object) ,new-value) - ,new-value) - `(,',accessor-name ,object))))) - (incf index))))) - ',name))) - - ;;; Environment (def!struct binding diff --git a/src/defstruct.lisp b/src/defstruct.lisp new file mode 100644 index 0000000..1872585 --- /dev/null +++ b/src/defstruct.lisp @@ -0,0 +1,69 @@ +;;; defstruct.lisp --- + +;; JSCL is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; JSCL is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with JSCL. If not, see . + +;; A very simple defstruct built on lists. It supports just slot with +;; an optional default initform, and it will create a constructor, +;; predicate and accessors for you. +(defmacro def!struct (name &rest slots) + (unless (symbolp name) + (error "It is not a full defstruct implementation.")) + (let* ((name-string (symbol-name name)) + (slot-descriptions + (mapcar (lambda (sd) + (cond + ((symbolp sd) + (list sd)) + ((and (listp sd) (car sd) (cddr sd)) + sd) + (t + (error "Bad slot description `~S'." sd)))) + slots)) + (predicate (intern (concat name-string "-P")))) + `(progn + ;; Constructor + (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions) + (list ',name ,@(mapcar #'car slot-descriptions))) + ;; Predicate + (defun ,predicate (x) + (and (consp x) (eq (car x) ',name))) + ;; Copier + (defun ,(intern (concat "COPY-" name-string)) (x) + (copy-list x)) + ;; Slot accessors + ,@(with-collect + (let ((index 1)) + (dolist (slot slot-descriptions) + (let* ((name (car slot)) + (accessor-name (intern (concat name-string "-" (string name))))) + (collect + `(defun ,accessor-name (x) + (unless (,predicate x) + (error "The object `~S' is not of type `~S'" x ,name-string)) + (nth ,index x))) + ;; TODO: Implement this with a higher level + ;; abstraction like defsetf or (defun (setf ..)) + (collect + `(define-setf-expander ,accessor-name (x) + (let ((object (gensym)) + (new-value (gensym))) + (values (list object) + (list x) + (list new-value) + `(progn + (rplaca (nthcdr ,',index ,object) ,new-value) + ,new-value) + `(,',accessor-name ,object))))) + (incf index))))) + ',name))) -- 1.7.10.4