anchor.diff:  (in-package "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY")
   
   
  -
  -
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;; 3 - EVALUATION AND COMPILATION
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
positive.code:               ((funcall ,cmp ,var ,lastvar))
              ,@body))))))
  
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; 7 - OBJECTS
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
  
  (defmacro pjb-defclass (name super &rest args)
    "
  
negative.code: 
  
  
  #||
  
  For :constructor, several options are allowed.
  
  
  |-----------------+--------------+----------------------+--------------------+-------------------------+--------------------------|
  |                 |              |                      |                    |                         |                          |
  |-----------------+--------------+----------------------+--------------------+-------------------------+--------------------------|
  | default name    | slot name    | slot name            | slot name          | specified prefix        |                          |
  |-----------------+--------------+----------------------+--------------------+-------------------------+--------------------------|
  |                 |              |                      |                    |                         |                          |
  |                 | :conc-name   | (:conc-name)         | (:conc-name nil)   | (:conc-name name)       |                          |
  | struct-slot     | slot         | slot                 | slot               | nameslot                |                          |
  |                 |              |                      |                    |                         |                          |
  |-----------------+--------------+----------------------+--------------------+-------------------------+--------------------------|
  |                 |              |                      |                    |                         |                          |
  |-----------------+--------------+----------------------+--------------------+-------------------------+--------------------------|
  | default name    | default name | default name         | no function        | specified name          | specified name           |
  |-----------------+--------------+----------------------+--------------------+-------------------------+--------------------------|
  |                 |              |                      |                    |                         |                          |
  |                 | :constructor | (:constructor)       | (:constructor nil) | (:constructor name)     | (:constructor name args) |
  | make-struct     | make-struct  | make-struct          | no constructor     | name :slot              | name arglist             |
  |                 |              |                      |                    |                         |                          |
  |                 | :copier      | (:copier)            | (:copier nil)      | (:copier name)          |                          |
  | copy-struct     | copy-struct  | copy-struct          | no copier          | name                    |                          |
  |                 |              |                      |                    |                         |                          |
  |                 | :predicate   | (:predicate)         | (:predicate nil)   | (:predicate name)       |                          |
  | struct-p        | struct-p     | struct-p             | no predicate       | name                    |                          |
  |                 |              |                      |                    |                         |                          |
  |-----------------+--------------+----------------------+--------------------+-------------------------+--------------------------|
  |                 |              |                      |                    |                         |                          |
  |                 |              | (:print-object)      |                    | (:print-object name)    |                          |
  | implemntation-  |              | default print-object |                    | print-object calls name |                          |
  | specific print  |              | method               |                    |                         |                          |
  |                 |              |                      |                    |                         |                          |
  |                 |              | (:print-function)    |                    | (:print-function name)  |                          |
  | implementation- |              | default print-object |                    | print-object calls name |                          |
  | specific print  |              | method               |                    |                         |                          |
  |                 |              |                      |                    |                         |                          |
  |-----------------+--------------+----------------------+--------------------+-------------------------+--------------------------|
  |                 | :named       |                      |                    |                         |                          |
  | not named       | named        |                      |                    |                         |                          |
  |                 |              |                      |                    |                         | (:include name slots*)   |
  |-----------------+--------------+----------------------+--------------------+-------------------------+--------------------------|
  |                 |              |                      |                    | (:initial-offset value) |                          |
  |                 |              |                      |                    | (:type type)            |                          |
  |-----------------+--------------+----------------------+--------------------+-------------------------+--------------------------|
  
  Using these results from GET-OPTION allows to distinguish all the cases:
  |--------------+--------------+--------------+-------------+------------------+------------------|
  |              | :foo         | (:foo)       | (:foo nil)  | (:foo name)      | (:foo name args) |
  |--------------+--------------+--------------+-------------+------------------+------------------|
  | nil          | :symbol      | :singleton   | (nil)       | (name)           | (name slots*)    |
  |--------------+--------------+--------------+-------------+------------------+------------------|
  | default name | slot name    | slot name    | slot name   | specified prefix |                  |
  |--------------+--------------+--------------+-------------+------------------+------------------|
  | default name | default name | default name | no function | specified name   | specified name   |
  |--------------+--------------+--------------+-------------+------------------+------------------|
  
  For conc-name:
  default-name = (null option)
  slot-name    = (or (atom option) (null (first option)))
  name         = (and (consp option) (first option))
  
  For others:
  default-name = (atom option)
  no-function  = (and (consp option) (null (first option)))
  name         = (and (consp option) (first option))
  
  ||#
  
  
  (defun option-key-p (key option)
    (eq key (if (symbolp option) option (car option))))
  
  (defun get-option (key options &optional list)
    (let ((opts (remove key options :test-not (function option-key-p))))
      (cond
        (list               opts)
        ((null opts)        nil)
        ((null (rest opts)) ; a single option
         (let ((opt (first opts)))
           (cond
             ((symbolp opt)     :symbol)
             ((null (rest opt)) :singleton)
             (t                 (rest opt)))))
        (t
         (error "Expected only one ~S option, not ~{~S~^ ~}." key opts)))))
  
  (defun make-conc-name (option prefix name suffix)
    (cond
      ((null option)
       (scat prefix name suffix))
      ((member option '(:symbol :singleton (nil)) :test (function equal))
       '||)
      ((and option (listp option) (car option))
       (car option))
      (t nil)))
  
  (defun make-name (option prefix name suffix)
    (cond
      ((or (null option) (and option (not (listp option))))
       (scat prefix name suffix))
      ((and option (listp option) (car option))
       (car option))
      (t nil)))
  
  (defun get-name (option)
    (if (and option (listp option))
        (car option)
        nil))
  
  (defun parse-structure-name-and-options (name-and-options)
    (let ((name    (if (symbolp name-and-options)
                       name-and-options
                       (car name-and-options)))
          (options (if (symbolp name-and-options)
                       nil
                       (cdr name-and-options))))
      (let ((conc-name        (get-option :conc-name      options))
            (constructors     (get-option :constructor    options :list))
            (copier           (get-option :copier         options))
            (predicate        (get-option :predicate      options))
            (print-function   (get-option :print-function options))
            (print-object     (get-option :print-object   options))
            (include          (get-option :include        options))
            (initial-offset   (get-option :initial-offset options))
            (structure-type-p (get-option :type           options))
            (structure-type   (get-option :type           options)))
        (when (and print-object print-function)
          (error 'simple-program-error
                 :format-control "Cannot have :print-object and :print-function options."))
        (when structure-type-p
          (unless (or (eql structure-type 'list)
                      (eql structure-type 'vector)
                      (and (listp structure-type)
                           (eql (first structure-type) 'vector)
                           (cdr structure-type)
                           (typep (second structure-type) '(integer 0))
                           (null (cddr structure-type))))
            (error 'simple-program-error
                   :format-control "Invalid structure :type option: ~S"
                   :format-arguments (list structure-type))))
        (let ((conc-name      (make-conc-name conc-name ""      name "-"))
              (copier         (make-name      copier    "COPY-" name ""))
              (predicate      (make-name      predicate ""      name "-P"))
              (print-function (get-name print-function))
              (print-object   (get-name print-object))
              (constructors   (if (null constructors)
                                  (list (make-name nil "MAKE-" name ""))
                                  (mapcan (lambda (x)
                                            (cond
                                              ((or (symbolp x) (= 1 (length x)))
                                               (list (make-name nil "MAKE-" name "")))
                                              ((null (second x))
                                               nil)
                                              ((= 2 (length x))
                                               (list (second x)))
                                              (t
                                               (list (list (second x) (third x))))))
                                          constructors))))
          (values name conc-name constructors copier
                  include initial-offset predicate
                  print-function print-object
                  structure-type-p structure-type)))))
  
  (defun parse-structure-definition (name-and-options doc-and-slots)
    (multiple-value-bind (name conc-name constructors copier
                          include initial-offset predicate
                          print-function print-object
                          structure-type-p structure-type)
        (parse-structure-name-and-options name-and-options)
      (let ((documentation (if (stringp (car doc-and-slots))
                               (car doc-and-slots)
                               nil))
            (slots        (if (stringp (car doc-and-slots))
                              (cdr doc-and-slots)
                              doc-and-slots)))
        (when (cdr include)
          (setf slots   (append (cddr include) slots)
                include (list (car include))))
        (let ((slot-names     (mapcar (lambda (s) (if (symbolp s) s (car s))) slots))
              (accessors      (mapcar (lambda (s) (make-name nil (or conc-name "")
                                                             (if (symbolp s) s (car s)) ""))
                                      slots)))
          (values name conc-name constructors copier
                  include initial-offset predicate
                  print-function print-object
                  structure-type-p structure-type
                  ;; --
                  documentation slots slot-names accessors)))))
  
  (defun generate-class-structure (name conc-name constructors copier
                                   include initial-offset predicate
                                   print-function print-object
                                   structure-type-p structure-type
                                   documentation slots slot-names accessors)
    `(progn
       (defclass ,name ,include
         ,(mapcar
  