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

Contents of /zip/ifstar.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (show 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 ;; 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