/[cmucl]/src/code/backq.lisp
ViewVC logotype

Contents of /src/code/backq.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations)
Fri Feb 8 13:30:51 1991 UTC (23 years, 2 months ago) by ram
Branch: MAIN
Changes since 1.1: +8 -4 lines
New file header with RCS header FILE-COMMENT.
1 ram 1.1 ;;; -*- Log: code.log; Mode: Lisp; Package: Lisp -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.2 ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8     ;;;
9     (ext:file-comment
10     "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/backq.lisp,v 1.2 1991/02/08 13:30:51 ram Exp $")
11     ;;;
12 ram 1.1 ;;; **********************************************************************
13     ;;;
14     ;;; BACKQUOTE: Code Spice Lispified by Lee Schumacher.
15     ;;;
16     (in-package 'lisp)
17    
18    
19     ;;; The flags passed back by BACKQUOTIFY can be interpreted as follows:
20     ;;;
21     ;;; |`,|: [a] => a
22     ;;; NIL: [a] => a ;the NIL flag is used only when a is NIL
23     ;;; T: [a] => a ;the T flag is used when a is self-evaluating
24     ;;; QUOTE: [a] => (QUOTE a)
25     ;;; APPEND: [a] => (APPEND . a)
26     ;;; NCONC: [a] => (NCONC . a)
27     ;;; LIST: [a] => (LIST . a)
28     ;;; LIST*: [a] => (LIST* . a)
29     ;;;
30     ;;; The flags are combined according to the following set of rules:
31     ;;; ([a] means that a should be converted according to the previous table)
32     ;;;
33     ;;; \ car || otherwise | QUOTE or | |`,@| | |`,.|
34     ;;;cdr \ || | T or NIL | |
35     ;;;================================================================================
36     ;;; |`,| || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a [d])
37     ;;; NIL || LIST ([a]) | QUOTE (a) | <hair> a | <hair> a
38     ;;;QUOTE or T|| LIST* ([a] [d]) | QUOTE (a . d) | APPEND (a [d]) | NCONC (a [d])
39     ;;; APPEND || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a . d) | NCONC (a [d])
40     ;;; NCONC || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a . d)
41     ;;; LIST || LIST ([a] . d) | LIST ([a] . d) | APPEND (a [d]) | NCONC (a [d])
42     ;;; LIST* || LIST* ([a] . d) | LIST* ([a] . d) | APPEND (a [d]) | NCONC (a [d])
43     ;;;
44     ;;;<hair> involves starting over again pretending you had read ".,a)" instead
45     ;;; of ",@a)"
46    
47     (defvar *backquote-count* 0 "How deep we are into backquotes")
48     (defvar *bq-comma-flag* '(|,|))
49     (defvar *bq-at-flag* '(|,@|))
50     (defvar *bq-dot-flag* '(|,.|))
51     (defvar *bq-vector-flag* '(|bqv|))
52    
53    
54     ;; This is the actual character macro.
55     (defun backquote-macro (stream ignore)
56     (declare (ignore ignore))
57     (let ((*backquote-count* (1+ *backquote-count*)))
58     (multiple-value-bind (flag thing)
59     (backquotify (read stream t nil t))
60     (if (eq flag *bq-at-flag*)
61     (error ",@ after backquote in ~S" thing))
62     (if (eq flag *bq-dot-flag*)
63     (error ",. after backquote in ~S" thing))
64     (values (backquotify-1 flag thing) 'list))))
65    
66     (defun comma-macro (stream ignore)
67     (declare (ignore ignore))
68     (unless (> *backquote-count* 0)
69     (when *read-suppress*
70     (return-from comma-macro nil))
71     (error "Comma not inside a backquote."))
72     (let ((c (read-char stream))
73     (*backquote-count* (1- *backquote-count*)))
74     (values
75     (cond ((char= c #\@)
76     (cons *bq-at-flag* (read stream t nil t)))
77     ((char= c #\.)
78     (cons *bq-dot-flag* (read stream t nil t)))
79     (t (unread-char c stream)
80     (cons *bq-comma-flag* (read stream t nil t))))
81     'list)))
82    
83     ;;; This does the expansion from table 2.
84     (defun backquotify (code)
85     (cond ((atom code)
86     (cond ((null code) (values nil nil))
87     ((or (numberp code)
88     (eq code t))
89     ;; Keywords are self evaluating. Install after packages.
90     (values t code))
91     (t (values 'quote code))))
92     ((or (eq (car code) *bq-at-flag*)
93     (eq (car code) *bq-dot-flag*))
94     (values (car code) (cdr code)))
95     ((eq (car code) *bq-comma-flag*)
96     (comma (cdr code)))
97     ((eq (car code) *bq-vector-flag*)
98     (multiple-value-bind (dflag d) (backquotify (cdr code))
99     (values 'vector (backquotify-1 dflag d))))
100     (t (multiple-value-bind (aflag a) (backquotify (car code))
101     (multiple-value-bind (dflag d) (backquotify (cdr code))
102     (if (eq dflag *bq-at-flag*)
103     ;; get the errors later.
104     (error ",@ after dot in ~S" code))
105     (if (eq dflag *bq-dot-flag*)
106     (error ",. after dot in ~S" code))
107     (cond
108     ((eq aflag *bq-at-flag*)
109     (if (null dflag)
110     (comma a)
111     (values 'append
112     (cond ((eq dflag 'append)
113     (cons a d ))
114     (t (list a (backquotify-1 dflag d)))))))
115     ((eq aflag *bq-dot-flag*)
116     (if (null dflag)
117     (comma a)
118     (values 'nconc
119     (cond ((eq dflag 'nconc)
120     (cons a d))
121     (t (list a (backquotify-1 dflag d)))))))
122     ((null dflag)
123     (if (memq aflag '(quote t nil))
124     (values 'quote (list a))
125     (values 'list (list (backquotify-1 aflag a)))))
126     ((memq dflag '(quote t))
127     (if (memq aflag '(quote t nil))
128     (values 'quote (cons a d ))
129     (values 'list* (list (backquotify-1 aflag a)
130     (backquotify-1 dflag d)))))
131     (t (setq a (backquotify-1 aflag a))
132     (if (memq dflag '(list list*))
133     (values dflag (cons a d))
134     (values 'list*
135     (list a (backquotify-1 dflag d)))))))))))
136    
137     ;;; This handles the <hair> cases
138     (defun comma (code)
139     (cond ((atom code)
140     (cond ((null code)
141     (values nil nil))
142     ((or (numberp code) (eq code 't))
143     (values t code))
144     (t (values *bq-comma-flag* code))))
145     ((eq (car code) 'quote)
146     (values (car code) (cadr code)))
147     ((memq (car code) '(append list list* nconc))
148     (values (car code) (cdr code)))
149     ((eq (car code) 'cons)
150     (values 'list* (cdr code)))
151     (t (values *bq-comma-flag* code))))
152    
153     ;;; This handles table 1.
154     (defun backquotify-1 (flag thing)
155     (cond ((or (eq flag *bq-comma-flag*)
156     (memq flag '(t nil)))
157     thing)
158     ((eq flag 'quote)
159     (list 'quote thing))
160     ((eq flag 'list*)
161     (cond ((null (cddr thing))
162     (cons 'cons thing))
163     (t (cons 'list* thing))))
164     ((eq flag 'vector)
165     (list 'apply '#'vector thing))
166     (t (cons (cdr
167     (assq flag
168     `((cons . cons) (list . list)
169     (append . append) (nconc . nconc))))
170     thing))))
171    
172    
173    
174    
175     (defun backq-init ()
176     (let ((*readtable* std-lisp-readtable))
177     (set-macro-character #\` #'backquote-macro)
178     (set-macro-character #\, #'comma-macro)))

  ViewVC Help
Powered by ViewVC 1.1.5