Line | |
---|
1 | ;; the if* macro used in Allegro: |
---|
2 | ;; |
---|
3 | ;; This is in the public domain... please feel free to put this definition |
---|
4 | ;; in your code or distribute it with your version of lisp. |
---|
5 | |
---|
6 | (defpackage :excl (:use :common-lisp) |
---|
7 | (:export #:if* #:then #:thenret #:else #:elseif)) |
---|
8 | (in-package :excl) |
---|
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 | |
---|
Note: See
TracBrowser
for help on using the repository browser.