Source

ilisp / guile-ilisp.scm

Full commit
youngs babe27e 



































































wbd 530b772 







youngs babe27e 













































wbd 530b772 



























youngs babe27e 





































































































































































































wbd 530b772 
youngs babe27e 












































wbd 530b772 


youngs babe27e 













  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
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
;;;; guile-ilisp.scm --- ILISP support functions for GUILE
;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> 
;;;
;;; Copyright (C) 2000 Matthias Koeppe
;;;
;;; This file is part of ILISP.
;;; Please refer to the file COPYING for copyrights and licensing
;;; information.
;;; Please refer to the file ACKNOWLEGDEMENTS for an (incomplete) list
;;; of present and past contributors.
;;;
;;; $Id$


(define-module (guile-ilisp)
  :use-module (ice-9 debug)
  :use-module (ice-9 session)
  :use-module (ice-9 documentation)
  :use-module (ice-9 regex))

(define-module (guile-user)
  :use-module (guile-ilisp))

(define-module (guile-ilisp))

(define (read-from-string str)
  (call-with-input-string str read))

(define (read-from-string/source str filename line column)
  "Read from string STR, pretending the source is the given FILENAME, LINE, COLUMN."
  (call-with-input-string
   str
   (lambda (port)
     (set-port-filename! port filename)
     (set-port-line! port (- line 1))
     (set-port-column! port (- column 1))
     (read port))))

(define (string->module str)
  (let ((v (call-with-input-string str read)))
    (cond
     ((eq? 'nil v) (current-module))
     ((pair? v) (resolve-module v))
     (else (resolve-module (list v))))))

(define (first-line s)
  (let ((i (string-index s #\newline)))
    (if i
	(substring s 0 i)
	s)))

(define (doc->arglist doc with-procedure?)
  "Parse DOC to find the arglist and return it as a string.  If
WITH-PROCEDURE?, include the procedure symbol."
  (let ((pattern " - primitive: "))
    (cond
     ((string=? (substring doc 0 (string-length pattern))
		pattern)
      ;; Guile 1.4.1 primitive procedure documentation, passed through
      ;; TeXinfo:
      ;;
      ;;  - primitive: assoc key alist
      ;;     Behaves like `assq' but uses `equal?' for key comparison.
      ;;
      ;; Continuation lines of arglists have an indentation of 10 chars.
      (let ((start-index
	     (if with-procedure?
		 (string-length pattern)
		 (min (1+ (or (string-index doc #\space
					    (string-length pattern))
			      (string-length pattern)))
		      (or (string-index doc #\newline
					(string-length pattern))
			  (string-length pattern))))))
	(let ((eol-index (or (string-index doc #\newline start-index)
			     (string-length doc))))
	  (string-append 
	   "("
	   (let loop ((bol-index (+ 1 eol-index))
		      (arglist (substring doc start-index eol-index)))
	     (cond 
	      ((and bol-index (>= bol-index (string-length doc)))
	       arglist)
	      ((and (>= (string-length doc) (+ bol-index 10))
		    (string=? (substring doc bol-index (+ bol-index 10))
			      "          "))
	       (let ((eol-index (string-index doc #\newline bol-index)))
		 (loop (and eol-index (+ 1 eol-index))
		       (string-append arglist " " 
				      (substring doc (+ bol-index 10)
						 eol-index)))))
	      (else
	       arglist)))
	   ")"))))
     ((string=? (substring doc 0 1) "(")
      ;; Guile <= 1.4 primitive procedure documentation and other
      ;; conventions:
      ;;
      ;; (help [NAME])
      ;; Prints useful information.  Try `(help)'.
      ;;
      (if with-procedure?
	  (first-line doc)
	  (let* ((f-l (first-line doc))
		 (index (string-index f-l #\space)))
	    (if index
		(string-append "("
			       (substring f-l
					  (+ index 1)))
		"()"))))     
     (else (string-append "CAN'T PARSE THIS DOCUMENTATION:\n"
			  doc)))))

(define (info-message sym obj expensive? arglist-only?)
  "Return an informational message about OBJ, which is the value of SYM.
For procedures, return procedure symbol and arglist, or
fall back to a message on the arity; if ARGLIST-ONLY?, return the
arglist only.  If EXPENSIVE?, take some more effort."
  ;; The code here is so lengthy because we want to return a
  ;; meaningful result even if we aren't allowed to read the
  ;; documentation files (EXPENSIVE? = #f).
    (cond
     ((and (procedure? obj)
	   (procedure-property obj 'arglist))
      => (lambda (arglist)
	   (let ((required-args (car arglist))
		 (optional-args (cadr arglist))
		 (keyword-args (caddr arglist))
		 (allow-other-keys? (cadddr arglist))
		 (rest-arg (car (cddddr arglist))))
	     (with-output-to-string
	       (lambda ()
		 (define (arg-only arg/default)
		   (if (pair? arg/default) (car arg/default) arg/default))
		 (write
		  (append
		   (if arglist-only?
		       '()
		       (list sym))
		   required-args
		   (if (not (null? optional-args))
		       (cons #:optional (map arg-only optional-args))
		       '())
		   (if (not (null? keyword-args))
		       (cons #:key (map arg-only keyword-args))
		       '())
		   (if allow-other-keys?
		       (list #:allow-other-keys)
		       '())
		   (if rest-arg rest-arg '()))))))))
     ((closure? obj)
      (let ((formals (cadr (procedure-source obj))))
	(if arglist-only? formals (cons sym formals))))
     ((or
       (and expensive?
	    (false-if-exception
	     ;; object-documentation was introduced in Guile 1.4,
	     ;; There is no documentation for primitives in earlier
	     ;; versions.
	     (object-documentation obj)))
       (and (procedure? obj)
	    (procedure-property obj 'documentation)
	    ;; The documentation property is attached to a primitive
	    ;; procedure when it was read from the documentation file
	    ;; before.
	    ))
      => (lambda (doc)
	   (doc->arglist doc (not arglist-only?))))
     ((and (macro? obj)
	   (macro-transformer obj)
	   (closure? (macro-transformer obj))
	   (procedure-documentation (macro-transformer obj)))
      ;; Documentation may be in the doc string of the transformer, as
      ;; is in session.scm (help).
      => (lambda (doc)
	   (doc->arglist doc (not arglist-only?))))
     ((procedure? obj)
      ;; Return a message about the arity of the procedure.
      (with-output-to-string
	(lambda () (arity obj))))
     (else #f)))

(define-public (ilisp-print-info-message sym package)
  "Evaluate SYM in PACKAGE and print an informational message about
the value.  For procedures, the arglist is printed.
This procedure is invoked by the electric space key."
  (let ((obj (catch #t
		    (lambda ()
		      (eval-in-package sym
				       (string->module package)))
		    (lambda args #f))))
		     
    (cond
     ((and obj
	   (info-message sym obj #f #f))
      => (lambda (message)
	   (display message)
	   (newline))))))

(define (if-defined symbol package
			   defined-procedure undefined-procedure)
  (let ((obj (catch #t
		    (lambda ()
		      (list (eval-in-package symbol
					     (string->module package))))
		    (lambda args #f))))
    (if obj
	(defined-procedure (car obj))
	(undefined-procedure))))

(define (strip-parens s)
  (if (and (string=? (substring s 0 1) "(")
	   (string=? (substring s (- (string-length s) 1)) ")"))
      (substring s 1 (- (string-length s) 1))
      s))      

(define (symbol-not-present symbol package)
  (display "Symbol `")
  (display symbol)
  (display "' not present in ")
  (cond
   ((string=? "nil" package)
    (display "the current module `")
    (for-each display (module-name (current-module)))
    (display "'"))
   (else
    (display "module `")
    (display (strip-parens package))
    (display "'")))
  (display ".\n"))

(define-public (ilisp-arglist symbol package)
  "Evaluate SYMBOL in PACKAGE and print the arglist if we have a
procedure. This procedure is invoked by `arglist-lisp'."
  (if-defined symbol package
	      (lambda (obj)
		(cond
		 ((info-message symbol obj #t #t)
		  => (lambda (message)
		       (display message)
		       (newline)))
		 (else
		  (display "Can't get arglist.")
		  (newline))))
	      (lambda ()
		(symbol-not-present symbol package))))

(define-public (ilisp-help symbol package)
  "Evaluate SYMBOL in PACKAGE and print help for it."
  (if-defined symbol package
	      (lambda (obj)
		(let ((doc (object-documentation obj)))
		  (if doc
		      (display doc)
		      (display "No documentation."))
		  (newline)))
	      (lambda ()
		(symbol-not-present symbol package))))

(define (word-separator? ch)
  (or (char=? ch #\-)
      (char=? ch #\:)
      (char=? ch #\_)
      (char=? ch #\/)))

(define (string-pred-rindex str pred)
  (let loop ((index (- (string-length str) 1)))
    (cond
     ((negative? index) #f)
     ((pred (string-ref str index)) index)
     (else (loop (- index 1))))))

(define (separate-fields-before-predicate pred str ret)
  (let loop ((fields '())
	     (str str))
    (cond
     ((string-pred-rindex str pred)
      => (lambda (w) (loop (cons (make-shared-substring str w) fields)
			   (make-shared-substring str 0 w))))
     (else (apply ret str fields)))))

(define (make-word-regexp str)
  (apply string-append
	 (cons "^"
	       (map (lambda (word)
		      (string-append (regexp-quote word) "[^-:/_]*"))
		    (separate-fields-before-predicate word-separator?
						      str list)))))	      

(define-public (ilisp-matching-symbols string package function? external? prefix?)
  (write (map (lambda (sym) (list (symbol->string sym)))
       (let ((regexp (if (eq? prefix? 't)
			 (string-append "^" (regexp-quote string))
			 (make-word-regexp string)))
	     (a-i apropos-internal))
	 (save-module-excursion
	  (lambda ()
	    (set-current-module (string->module package))
	    (a-i regexp))))))
  (newline))

(define (last l)
  (cond ((and (pair? l) (not (null? (cdr l))))
	 (last (cdr l)))
	(else (car l))))

(define eval-in-package
  ;; A two-argument version of `eval'
  (if (= (car (procedure-property eval 'arity)) 2)
      (lambda (expression environment)	; we have a R5RS eval
	(save-module-excursion
	 (lambda ()
	   (eval expression environment))))
      (lambda (expression environment)	; we have a one-arg eval (Guile <= 1.4)
	(save-module-excursion
	 (lambda ()
	   (set-current-module environment)
	   (eval expression))))))  

(define-public (ilisp-get-package sequence-of-defines)
  "Get the last module name defined in the sequence of define-module forms."
  ;; First eval the sequence-of-defines.  This will register the
  ;; module with the Guile interpreter if it isn't there already.
  ;; Otherwise `resolve-module' will give us a bad environment later,
  ;; which just makes trouble.
  (let ((name
	 (eval-in-package 
	  (append sequence-of-defines
		  '((module-name (current-module))))
	  (string->module "(guile-user)"))))
    (cond
     ((pair? name)
      ;; This version of Guile has a module-name procedure that
      ;; returns the full module name.  Good.
      (write name))
     (else 
      ;; Now we have the name of the module -- but only the last
      ;; component.  We need to "parse" the sequence-of-defines
      ;; ourselves.
      (let ((last-form (last sequence-of-defines)))
	(cond ((and (pair? last-form)
		    (eq? (car last-form) 'define-module))
	       (write (cadr last-form)))
	      (else (write '(guile-user))))))))
  (newline))

(define-public (ilisp-in-package package)
  (set-current-module (string->module package))
  (process-use-modules '(((guile-ilisp))))
  *unspecified*)

(define-public (ilisp-eval form package filename line)
  "Evaluate FORM in PACKAGE recording FILENAME as the source file
and LINE as the source code line there."
  (eval-in-package
   (read-from-string/source form filename line 1)
   (string->module package)))

(define-public (ilisp-trace symbol package breakp)
  (trace (eval-in-package symbol (string->module package)))
  *unspecified*)

(define-public (ilisp-untrace symbol package)
  (untrace (eval-in-package symbol (string->module package)))
  *unspecified*)

(define (or-map* f list)
  "Apply f to successive elements of l until exhaustion or improper end
or while f returns #f. If returning early, return the return value of f."
  (let loop ((result #f)
	     (l list))
    (or result
	(and (pair? l)
	     (loop (f (car l)) (cdr l))))))

(define-public (ilisp-source-file symbol package)
  "Find the source file of SYMBOL's definition in PACKAGE."
  (catch #t
	 (lambda ()
	   (let ((value (eval-in-package (read-from-string symbol)
					 (string->module package))))
	     (cond
	      ((and (procedure? value)
		    (procedure-source value))
	       => (lambda (source)
		    (and=>
		     (or-map* (lambda (s)
				(false-if-exception
				 (source-property s 'filename)))
			      source)
		     (lambda (filename) (throw 'result filename))))))
	     (write 'nil)))
	 (lambda (key . args)
	   (if (eq? key 'result)
	       (begin (write (car args)) (newline) (write #t))
	       (begin (write 'nil)))))
  (newline))

(define-public (ilisp-macroexpand-1 expression package)
  (write (save-module-excursion
   (lambda ()
     (set-current-module (string->module package))
     (macroexpand-1 (read-from-string expression)))))
  (newline))

(define-public (ilisp-macroexpand expression package)
  (write (save-module-excursion
   (lambda ()
     (set-current-module (string->module package))
     (macroexpand (read-from-string expression)))))
  (newline))