guile-1.8-libs 1.8.8+1-6ubuntu2 / usr / share / guile / 1.8 / lang / elisp / primitives / syntax.scm

This file is indexed.

/usr/share/guile/1.8/lang/elisp/primitives/syntax.scm is in guile-1.8-libs 1.8.8+1-6ubuntu2.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below. 

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
(define-module (lang elisp primitives syntax)
  #:use-module (lang elisp internals evaluation)
  #:use-module (lang elisp internals fset)
  #:use-module (lang elisp internals lambda)
  #:use-module (lang elisp internals set)
  #:use-module (lang elisp internals trace)
  #:use-module (lang elisp transform))

;;; Define Emacs Lisp special forms as macros.  This is more flexible
;;; than handling them specially in the translator: allows them to be
;;; redefined, and hopefully allows better source location tracking.

;;; {Variables}

(define (setq exp env)
  (cons begin
	(let loop ((sets (cdr exp)))
	  (if (null? sets)
	      '()
	      (cons `(,set (,quote ,(car sets)) ,(transformer (cadr sets)))
		    (loop (cddr sets)))))))

(fset 'setq
      (procedure->memoizing-macro setq))

(fset 'defvar
      (procedure->memoizing-macro
        (lambda (exp env)
	  (trc 'defvar (cadr exp))
	  (if (null? (cddr exp))
	      `(,quote ,(cadr exp))
	      `(,begin (,if (,not (,defined? (,quote ,(cadr exp))))
			    ,(setq (list (car exp) (cadr exp) (caddr exp)) env))
		       (,quote ,(cadr exp)))))))

(fset 'defconst
      (procedure->memoizing-macro
        (lambda (exp env)
	  (trc 'defconst (cadr exp))
	  `(,begin ,(setq (list (car exp) (cadr exp) (caddr exp)) env)
		   (,quote ,(cadr exp))))))

;;; {lambda, function and macro definitions}

(fset 'lambda
      (procedure->memoizing-macro
       (lambda (exp env)
	 (transform-lambda/interactive exp '<elisp-lambda>))))

(fset 'defun
      (procedure->memoizing-macro
       (lambda (exp env)
	 (trc 'defun (cadr exp))
	 `(,begin (,fset (,quote ,(cadr exp))
			 ,(transform-lambda/interactive (cdr exp)
							(symbol-append '<elisp-defun:
								       (cadr exp)
								       '>)))
		  (,quote ,(cadr exp))))))

(fset 'interactive
      (procedure->memoizing-macro
        (lambda (exp env)
	  (fluid-set! interactive-spec exp)
	  #f)))

(fset 'defmacro
      (procedure->memoizing-macro
       (lambda (exp env)
	 (trc 'defmacro (cadr exp))
	 (call-with-values (lambda () (parse-formals (caddr exp)))
	   (lambda (required optional rest)
	     (let ((num-required (length required))
		   (num-optional (length optional)))
	       `(,begin (,fset (,quote ,(cadr exp))
			       (,procedure->memoizing-macro
				(,lambda (exp1 env1)
				  (,trc (,quote using) (,quote ,(cadr exp)))
				  (,let* ((%--args (,cdr exp1))
					  (%--num-args (,length %--args)))
				    (,cond ((,< %--num-args ,num-required)
					    (,error "Wrong number of args (not enough required args)"))
					   ,@(if rest
						 '()
						 `(((,> %--num-args ,(+ num-required num-optional))
						    (,error "Wrong number of args (too many args)"))))
					   (else (,transformer
						  (, @bind ,(append (map (lambda (i)
									   (list (list-ref required i)
										 `(,list-ref %--args ,i)))
									 (iota num-required))
								    (map (lambda (i)
									   (let ((i+nr (+ i num-required)))
									     (list (list-ref optional i)
										   `(,if (,> %--num-args ,i+nr)
											 (,list-ref %--args ,i+nr)
											 ,%nil))))
									 (iota num-optional))
								    (if rest
									(list (list rest
										    `(,if (,> %--num-args
											      ,(+ num-required
												  num-optional))
											  (,list-tail %--args
												      ,(+ num-required
													  num-optional))
											  ,%nil)))
									'()))
							   ,@(map transformer (cdddr exp)))))))))))))))))

;;; {Sequencing}

(fset 'progn
      (procedure->memoizing-macro
        (lambda (exp env)
	  `(,begin ,@(map transformer (cdr exp))))))

(fset 'prog1
      (procedure->memoizing-macro
        (lambda (exp env)
	  `(,let ((%--res1 ,(transformer (cadr exp))))
	     ,@(map transformer (cddr exp))
	     %--res1))))

(fset 'prog2
      (procedure->memoizing-macro
        (lambda (exp env)
	  `(,begin ,(transformer (cadr exp))
		   (,let ((%--res2 ,(transformer (caddr exp))))
		     ,@(map transformer (cdddr exp))
		     %--res2)))))

;;; {Conditionals}

(fset 'if
      (procedure->memoizing-macro
        (lambda (exp env)
	  (let ((else-case (cdddr exp)))
	    (cond ((null? else-case)
		   `(,nil-cond ,(transformer (cadr exp)) ,(transformer (caddr exp)) ,%nil))
		  ((null? (cdr else-case))
		   `(,nil-cond ,(transformer (cadr exp))
			       ,(transformer (caddr exp))
			       ,(transformer (car else-case))))
		  (else
		   `(,nil-cond ,(transformer (cadr exp))
			       ,(transformer (caddr exp))
			       (,begin ,@(map transformer else-case)))))))))

(fset 'and
      (procedure->memoizing-macro
        (lambda (exp env)
	  (cond ((null? (cdr exp)) #t)
		((null? (cddr exp)) (transformer (cadr exp)))
		(else
		 (cons nil-cond
		       (let loop ((args (cdr exp)))
			 (if (null? (cdr args))
			     (list (transformer (car args)))
			     (cons (list not (transformer (car args)))
				   (cons %nil
					 (loop (cdr args))))))))))))

;;; NIL-COND expressions have the form:
;;;
;;; (nil-cond COND VAL COND VAL ... ELSEVAL)
;;;
;;; The CONDs are evaluated in order until one of them returns true
;;; (in the Elisp sense, so not including empty lists).  If a COND
;;; returns true, its corresponding VAL is evaluated and returned,
;;; except if that VAL is the unspecified value, in which case the
;;; result of evaluating the COND is returned.  If none of the COND's
;;; returns true, ELSEVAL is evaluated and its value returned.

(define <-- *unspecified*)

(fset 'or
      (procedure->memoizing-macro
        (lambda (exp env)
	  (cond ((null? (cdr exp)) %nil)
		((null? (cddr exp)) (transformer (cadr exp)))
		(else
		 (cons nil-cond
		       (let loop ((args (cdr exp)))
			 (if (null? (cdr args))
			     (list (transformer (car args)))
			     (cons (transformer (car args))
				   (cons <--
					 (loop (cdr args))))))))))))

(fset 'cond
      (procedure->memoizing-macro
       (lambda (exp env)
	 (if (null? (cdr exp))
	     %nil
	     (cons
	      nil-cond
	      (let loop ((clauses (cdr exp)))
		(if (null? clauses)
		    (list %nil)
		    (let ((clause (car clauses)))
		      (if (eq? (car clause) #t)
			  (cond ((null? (cdr clause)) (list #t))
				((null? (cddr clause))
				 (list (transformer (cadr clause))))
				(else `((,begin ,@(map transformer (cdr clause))))))
			  (cons (transformer (car clause))
				(cons (cond ((null? (cdr clause)) <--)
					    ((null? (cddr clause))
					     (transformer (cadr clause)))
					    (else
					     `(,begin ,@(map transformer (cdr clause)))))
				      (loop (cdr clauses)))))))))))))

(fset 'while
      (procedure->memoizing-macro
        (lambda (exp env)
	  `((,letrec ((%--while (,lambda ()
				  (,nil-cond ,(transformer (cadr exp))
					     (,begin ,@(map transformer (cddr exp))
						     (%--while))
					     ,%nil))))
	      %--while)))))

;;; {Local binding}

(fset 'let
      (procedure->memoizing-macro
        (lambda (exp env)
	  `(, @bind ,(map (lambda (binding)
			    (trc 'let binding)
			    (if (pair? binding)
				`(,(car binding) ,(transformer (cadr binding)))
				`(,binding ,%nil)))
			  (cadr exp))
		    ,@(map transformer (cddr exp))))))

(fset 'let*
      (procedure->memoizing-macro
        (lambda (exp env)
	  (if (null? (cadr exp))
	      `(,begin ,@(map transformer (cddr exp)))
	      (car (let loop ((bindings (cadr exp)))
		     (if (null? bindings)
			 (map transformer (cddr exp))
			 `((, @bind (,(let ((binding (car bindings)))
					(if (pair? binding)
					    `(,(car binding) ,(transformer (cadr binding)))
					    `(,binding ,%nil))))
				    ,@(loop (cdr bindings)))))))))))

;;; {Exception handling}

(fset 'unwind-protect
      (procedure->memoizing-macro
        (lambda (exp env)
	  (trc 'unwind-protect (cadr exp))
	  `(,let ((%--throw-args #f))
	     (,catch #t
	       (,lambda ()
		 ,(transformer (cadr exp)))
	       (,lambda args
		 (,set! %--throw-args args)))
	     ,@(map transformer (cddr exp))
	     (,if %--throw-args
		  (,apply ,throw %--throw-args))))))

APT Browse - Built by Thomas Orozco.