source: trunk/source/lib/number-case-macro.lisp @ 14423

Last change on this file since 14423 was 13067, checked in by rme, 10 years ago

Update copyright notices.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 4.6 KB
Line 
1;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18(in-package "CCL")
19
20;;;;;;;;;
21;; support fns and vars for number-case
22
23(defun type-name-to-code (name)
24  (funcall (arch::target-numeric-type-name-to-typecode-function
25            (backend-target-arch *target-backend*))
26           name))
27
28(defvar nd-onions `((integer fixnum bignum) (rational fixnum bignum ratio)
29                    (float double-float short-float)
30                    (real fixnum bignum ratio double-float short-float)
31                    (number fixnum bignum ratio double-float short-float complex)))
32
33(defun nd-diff (x y) ; things in x that are not in y
34  (let ((res))
35    (dolist (e x)
36      (when (not (memq e y))(push e res)))
37    res))
38
39(defun nd-type-compose (selectors)
40  ;; this could do better but probably not worth the trouble - only
41  ;; for require-type error
42  (or (dolist (union nd-onions)
43        (if (when (eq (length selectors)(length (cdr union)))
44              (dolist (e selectors t)(if (not (memq e (cdr union)))(return))))
45          (return (car union))))
46      (cons 'or selectors)))
47
48
49
50;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
51;;
52;; Simpler number dispatch. Syntax is just like case.
53;;
54;; (number-case x                 =>         (case (typecode x)
55;;     (fixnum (print 4))                       (target::tag-fixnum (print 4)) ; actually tag value
56;;     ((bignum ratio)(print 5)))               ((target::tag-bignum target::tag-ratio)(print 5))
57;;                                              (t (require-type x 'rational))))
58;;                                               
59
60(defmacro number-case (var &rest cases)
61  (let ((selectors-so-far)
62        (t-case nil)
63        (tag (gensym))
64        (block (gensym)))
65    (flet ((maybe-compound (selector)
66             (let ((compound (cdr (assq selector nd-onions))))
67               (when compound
68                 (setq compound (nd-diff compound selectors-so-far))
69                 (when (not compound)(error "Unreachable case ~s" selector))
70                 (setq selectors-so-far
71                       (append compound selectors-so-far))
72                 compound))))
73      (declare (dynamic-extent #'maybe-compound))
74      `(block ,block
75         (tagbody 
76           ,tag
77           (return-from ,block             
78             (case (typecode ,var)
79               ,@(mapcar 
80                  #'(lambda (case)
81                      (let ((selector (car case)))
82                        (if (atom selector)
83                          (cond ((eq selector t)(setq t-case t))
84                                ((memq selector selectors-so-far)(error "Unreachable case ~s" selector))
85                                ((let ((compound (maybe-compound selector)))
86                                   (when compound
87                                     (setq selector compound))))
88                                (t (push selector selectors-so-far)))
89                          (progn
90                            (setq selector
91                                  (mapcan #'(lambda (item)
92                                              (cond ((memq item selectors-so-far))
93                                                    ((let ((compound (maybe-compound item)))
94                                                       (when compound
95                                                         (setq item compound))))
96                                                    (t (push item selectors-so-far)))
97                                              (if (listp item) item (list item)))
98                                          selector))))
99                        (setq selector (if (listp selector)
100                                         (mapcar #'type-name-to-code selector)
101                                         (if (eq selector t) t
102                                             (type-name-to-code selector))))
103                        `(,selector ,@(cdr case))))
104                  cases)
105               ,@(if (not t-case)
106                   `((t (setq ,var (%kernel-restart $xwrongtype ,var ',(nd-type-compose selectors-so-far)))
107                        (go ,tag)))))))))))
108
109(provide "NUMBER-CASE-MACRO")
Note: See TracBrowser for help on using the repository browser.