/[zip]/zip/ifstar.lisp
ViewVC logotype

Contents of /zip/ifstar.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (hide annotations) (vendor branch)
Sun Apr 3 19:36:28 2005 UTC (9 years ago) by dlichteblau
Branch: dlichteblau, MAIN
CVS Tags: start, HEAD
Changes since 1.1: +0 -0 lines
initial import
1 dlichteblau 1.1 ;; inflate.lisp benutzt if*...
2    
3     (in-package :zip)
4    
5     ;; the if* macro used in Allegro:
6     ;;
7     ;; This is in the public domain... please feel free to put this definition
8     ;; in your code or distribute it with your version of lisp.
9    
10     (defvar if*-keyword-list '("then" "thenret" "else" "elseif"))
11    
12     (defmacro if* (&rest args)
13     (do ((xx (reverse args) (cdr xx))
14     (state :init)
15     (elseseen nil)
16     (totalcol nil)
17     (lookat nil nil)
18     (col nil))
19     ((null xx)
20     (cond ((eq state :compl)
21     `(cond ,@totalcol))
22     (t (error "if*: illegal form ~s" args))))
23     (cond ((and (symbolp (car xx))
24     (member (symbol-name (car xx))
25     if*-keyword-list
26     :test #'string-equal))
27     (setq lookat (symbol-name (car xx)))))
28    
29     (cond ((eq state :init)
30     (cond (lookat (cond ((string-equal lookat "thenret")
31     (setq col nil
32     state :then))
33     (t (error
34     "if*: bad keyword ~a" lookat))))
35     (t (setq state :col
36     col nil)
37     (push (car xx) col))))
38     ((eq state :col)
39     (cond (lookat
40     (cond ((string-equal lookat "else")
41     (cond (elseseen
42     (error
43     "if*: multiples elses")))
44     (setq elseseen t)
45     (setq state :init)
46     (push `(t ,@col) totalcol))
47     ((string-equal lookat "then")
48     (setq state :then))
49     (t (error "if*: bad keyword ~s"
50     lookat))))
51     (t (push (car xx) col))))
52     ((eq state :then)
53     (cond (lookat
54     (error
55     "if*: keyword ~s at the wrong place " (car xx)))
56     (t (setq state :compl)
57     (push `(,(car xx) ,@col) totalcol))))
58     ((eq state :compl)
59     (cond ((not (string-equal lookat "elseif"))
60     (error "if*: missing elseif clause ")))
61     (setq state :init)))))
62    

  ViewVC Help
Powered by ViewVC 1.1.5