From 4f4f0aad6db508de2a59d29b59cc738a6ece4c4d Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <matthias@benkard.de>
Date: Sun, 3 Aug 2008 10:43:56 +0200
Subject: Add DEFTYPE.

---
 defun-1.lisp | 10 +++++++---
 types.lisp   | 27 +++++++++++++++++++++++----
 2 files changed, 30 insertions(+), 7 deletions(-)

diff --git a/defun-1.lisp b/defun-1.lisp
index 51e9db0..875b7a5 100644
--- a/defun-1.lisp
+++ b/defun-1.lisp
@@ -21,7 +21,7 @@
 (export '(defmacro defun))
 
 
-(%defun* make-defun-body (lambda-list body)
+(%defun* make-defun-body (lambda-list body destructuring-p)
   (let ((lambda-sym (gensym)))
     `(,lambda-sym
        (d-b ,lambda-list nil nil ,lambda-sym
@@ -29,7 +29,7 @@
 
 (%defmacro* defun (name lambda-list . body)
   `(%defun ,name
-     ,@(make-defun-body lambda-list body)))
+     ,@(make-defun-body lambda-list body nil)))
 
 (%defun* make-defmacro-body (lambda-list body)
   (let ((arg-sym (gensym))
@@ -49,7 +49,11 @@
 
 (%defmacro* lambda (lambda-list . body)
   `(%lambda
-     ,@(make-defun-body lambda-list body)))
+     ,@(make-defun-body lambda-list body nil)))
+
+(%defmacro* destructuring-lambda (lambda-list . body)
+  `(%lambda
+     ,@(make-defun-body lambda-list body t)))
 
 (defun funcall (function &rest arguments)
   (apply function arguments))
diff --git a/types.lisp b/types.lisp
index 24a962d..91c8ac9 100644
--- a/types.lisp
+++ b/types.lisp
@@ -26,7 +26,7 @@
           array simple-array simple-vector simple-string
           simple-bit-vector sequence two-way-stream stream echo-stream
           broadcast-stream file-stream synonym-stream string-stream
-          concatenated-stream))
+          concatenated-stream deftype))
 
 
 (setq *subtype-supertypes-dict*
@@ -69,6 +69,10 @@
           (send-by-name dict "setObject:forKey:" (cdr pair) (nullify (car pair))))))
 
 
+(setq *type-expanders* (send-by-name (find-objc-class "NSMutableDictionary")
+                                     "dictionary"))
+
+
 (setq most-positive-fixnum 32767)
 (setq most-negative-fixnum -32768)
 
@@ -107,10 +111,25 @@
            (every1 function (rest list)))))
 
 
-(defun expand-type (type &optional environment)
-  ;;FIXME: DEFTYPE
-  type)
+(defmacro deftype (type-name lambda-list &body body)
+  `(send-by-name *type-expanders*
+                 "setObject:forKey:"
+                 (destructuring-lambda ,lambda-list ,@body)
+                 ',type-name))
 
+(defun expand-type (type &optional environment)
+  (let* ((env (if rest (car rest) nil))
+         (expansion-1 (expand-type-1 object env))
+         (expansion-2 (expand-type-1 expansion-1 env)))
+    (if (list-eqp expansion-1 expansion-2)
+        expansion-1
+        (expand-type expansion-2))))
+
+(defun expand-type-1 (type &optional environment)
+  (let ((expander (send-by-name *type-expanders* "objectForKey:" (first type))))
+    (if expander
+        (apply expander (rest type))
+        type)))
 
 (defun typep (thing typespec &optional environment)
   ;;FIXME: DEFTYPE
-- 
cgit v1.2.3