home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Boot / class-macs.em < prev    next >
Encoding:
Text File  |  1993-02-02  |  1.8 KB  |  82 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: class-macs.em
  4. ;; Date: Mon Dec 14 11:39:08 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;
  9.  
  10. (defmodule class-macs
  11.   ((except (scan-args) standard0)
  12.    list-fns
  13.    )
  14.   ()
  15.  
  16.   (export find-class find-slot the-classlist find-slot 
  17.       accessor-location
  18.       define-prim-class reset-classes)
  19.  
  20.   (defun scan-args (arg lst default)
  21.     (cond ((null lst) default)
  22.       ((eq (car lst) arg) (car (cdr lst)))
  23.       (t (scan-args arg
  24.             (cdr (cdr lst))
  25.             default))))
  26.  
  27.   
  28.   (deflocal *defs* nil)
  29.  
  30.   (deflocal find-slot (mk-finder))
  31.   (deflocal find-class (mk-finder))
  32.  
  33.   (defun reset-classes () 
  34.     (progn (setq *defs* nil)
  35.        nil))
  36.  
  37.   (defun the-classlist () *defs*)
  38.  
  39.   (defmacro define-prim-class (name supers slots . options)
  40.     (let ((classd (make-class-init-list name supers slots options)))
  41.       ((setter find-class) (scan-args 'name classd 'anonymous) classd)
  42.       (setq *defs* 
  43.         (nconc *defs*
  44.            (list classd)))
  45.       nil))
  46.  
  47.   (defun make-class-init-list (name supers slots options)
  48.     (append (list 'name name
  49.           'direct-superclasses supers
  50.           'direct-slot-descriptions 
  51.           (mapcar (lambda (d) 
  52.                 (let ((s (append (list 'class-name name)
  53.                          (cons 'name d))))
  54.                   (make-slot-record s)
  55.                   s))
  56.               slots))
  57.         options))
  58.  
  59.   (defun make-slot-record (slotd)
  60.     (let ((accessor (scan-args 'accessor slotd nil)))
  61.       (if (null accessor) nil
  62.       ((setter find-slot) accessor (cons (scan-args 'position slotd nil)
  63.                          slotd)))))
  64.   
  65.   
  66.   ;; Should be slot-desc-position
  67.   (defun accessor-location (x) 
  68.     (let ((aa (find-slot x)))
  69.       (if (null aa) nil
  70.     (car aa))))
  71.  
  72.   (deflocal *socks* t)
  73.   (defun set-sockets (x) (setq *socks* x))
  74.   
  75.   (defmacro with-sockets x
  76.     (if *socks* `(progn ,@x)
  77.       nil))
  78.   
  79.   (export with-sockets set-sockets)
  80.   ;; end module
  81.   )
  82.