source: project/release/4/readline/trunk/readline.scm @ 32660

Last change on this file since 32660 was 32660, checked in by Alexej Magura, 5 years ago

updates for chicken 4.10

File size: 20.9 KB
Line 
1;;; Add-in module to support using GNU readline from Chicken.
2;
3; (Readline is GPLed, so that makes this file GPLed too, because this
4; file will only run if it's linked against readline.)
5;
6; Copyright (c) 2002 Tony Garnock-Jones
7; Copyright (c) 2006 Heath Johns (paren bouncing and auto-completion code)
8; Copyright (c) 2014 Alexej Magura (toplevel commands and readline#session)
9;
10; This program is free software; you can redistribute it and/or modify
11; it under the terms of the GNU General Public License as published by
12; the Free Software Foundation; either version 2 of the License, or
13; (at your option) any later version.
14;
15; This program is distributed in the hope that it will be useful,
16; but WITHOUT ANY WARRANTY; without even the implied warranty of
17; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18; GNU General Public License for more details.
19;
20; You should have received a copy of the GNU General Public License
21; along with this program; if not, write to the Free Software
22; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
23
24;---------------------------------------------------------------------------
25; csc -s readline.scm -L -lreadline -L -ltermcap
26;
27; To get csi to support line editing, install this library and put the
28; following lines in your ~/.csirc:
29;
30;   (require 'readline)
31;   (current-input-port (readline#make-readline-port "csi> "))
32;
33; If you also want to make the command history span sessions, add the
34; following:
35;
36;   (readline#history-install-file-manager (string-append (or (getenv "HOME") ".") "/.csi.history"))
37;
38; By default this will save 1000 lines of history between sessions (it
39; will prune the history file to 1000 lines at startup). For a
40; different history size, pass the desired number of lines as the
41; (optional) second argument to gnu-history-install-file-manager. If
42; #f is passed in, no history-file-pruning will take place.
43;
44; To pass configuration options to readline (see the readline manual page for
45; details):
46;
47; (gnu-readline-parse-and-bind "set editing-mode vi")
48;
49;
50; To change the "still waiting for input" prompt, just pass it as a second
51; argument to make-readline-port:
52;
53; (current-input-port (make-gnu-readline-port "csi> " ".... "))
54;
55;
56; The neato line numbered display that's the csi default doesn't work, but
57; here's how to write a replacement:
58;
59;(repl-prompt
60;  (let ((history-count -1))
61;       (lambda ()
62;         (set! history-count (+ 1 history-count))
63;         (sprintf "#;~A> " hist))))
64
65(declare
66 (usual-integrations))
67
68; hack around missing export from `chicken' in 4.0.1:
69
70(define ##readline#repl-prompt repl-prompt)
71
72;;;; Toplevel Commands
73
74(module readline (
75                  ;; variables
76                  session
77                  version
78
79                  ;; functions
80                  readline
81                  make-readline-port
82                  clear-history
83                  %signal-cleanup
84                  read-history
85                  write-history
86                  append-history
87                  truncate-history
88
89                  %add-history%
90                  %remove-history%
91
92                  set-bounce-ms
93
94                  history-newlines
95                  history-list
96                  history-position
97
98                  search-history
99                  search-history-starts-with
100                  search-history-from-position
101                  search-history-forward
102                  search-history-backward
103                  search-history-starts-with-forward
104                  search-history-starts-with-backward
105
106                  current-history-line
107                  last-history-line
108                  eval-last-history-line
109
110;                 history-stifle
111;                 history-stifled
112
113                  install-history-file
114
115                  parse-and-bind
116                  completions
117                  variables
118                  )
119(import scheme chicken foreign ports data-structures)
120(use posix irregex)
121
122#>
123#include "readline-egg.c"
124
125C_regparm C_word C_enumerate_symbols(C_SYMBOL_TABLE *stable, C_word pos)
126{
127  int i;
128  C_word
129    sym,
130    bucket = C_u_i_car(pos);
131
132  if(!C_truep(bucket)) return C_SCHEME_FALSE; /* end already reached */
133  else i = C_unfix(bucket);
134
135  bucket = C_u_i_cdr(pos);
136
137  while(bucket == C_SCHEME_END_OF_LIST) {
138    if(++i >= stable->size) {
139      C_set_block_item(pos, 0, C_SCHEME_FALSE);        /* no more buckets */
140      return C_SCHEME_FALSE;
141    }
142    else bucket = stable->table[ i ];
143  }
144
145  sym = C_block_item(bucket, 0);
146  C_set_block_item(pos, 0, C_fix(i));
147  C_mutate2(&C_u_i_cdr(pos), C_block_item(bucket, 1));
148  return sym;
149}
150
151<#
152
153;; Initialise (note the extra set of parens)
154((foreign-lambda void "gnu_readline_init"))
155
156(define-syntax var-fn
157  (syntax-rules ()
158    ((_ c-name set)
159     (if set
160         ((foreign-lambda bool c-name int) set)
161         ((foreign-lambda bool c-name int) -1)))))
162
163(define-inline (var-set name c-name)
164  `(set! (setter ,@name)
165    (lambda (set)
166      (set! set (or
167                 (and (or (= set 0) (= set 1) (= set -1)) set)
168                 0))
169      ((foreign-lambda bool ,c-name int) set))))
170
171#|/////////////////////////////////|#
172;;;; Private Functions
173#|/////////////////////////////////|#
174(define-inline (setkv! kvlst key value)
175  (let ((kv (member key kvlst)))
176    (if kv
177        (set-car! (cdr kv) value))))
178
179(define-inline (getkv kvlst key #!optional default)
180  (let ((kv (member key kvlst)))
181    (if kv
182        (cadr kv)
183        default)))
184#|/////////////////////////////////|#
185;;;; Public Variables
186#|/////////////////////////////////|#
187(define session '(#:load-history-file #t
188                  #:save-history-on-exit #t
189                  #:record-history #t
190                  #:verify-history-expansions #f))
191(define version "4.1.0")
192#|/////////////////////////////////|#
193;;;; Private Variables
194#|/////////////////////////////////|#
195
196;; get access to the quoting flag
197(define-foreign-variable is-quoted? int "rl_completion_quote_character")
198(define-foreign-variable filename-completion int "rl_filename_completion_desired")
199
200#|/////////////////////////////////|#
201;;;; Private C->Scheme Functions
202#|/////////////////////////////////|#
203(define-inline (.readline. toplevel-prompt mid-expression-prompt #!optional add-to-history)
204  ((foreign-safe-lambda c-string "gnu_readline_readline" c-string c-string bool)
205   toplevel-prompt mid-expression-prompt add-to-history))
206
207(define-inline (.number->bool. num)
208  ((foreign-lambda bool "int_to_bool" int) num))
209
210#|/////////////////////////////////|#
211;;;; Public C->Scheme Functions
212#|/////////////////////////////////|#
213(define (readline toplevel-prompt mid-expression-prompt)
214  (.readline. toplevel-prompt mid-expression-prompt (not (getkv session #:record-history))))
215
216(define %signal-cleanup
217  (foreign-lambda void "gnu_readline_signal_cleanup"))
218
219(define clear-history
220  (foreign-lambda void "clear_history"))
221
222;;; (gnu-readline-read-history <filename-or-false>) -> 0 for success, errno for failure
223(define read-history
224  (foreign-lambda int "read_history" c-string))
225
226;;; (gnu-readline-write-history <filename-or-false>) -> 0 for success, errno for failure
227(define write-history
228  (foreign-lambda int "write_history" c-string))
229
230(define append-history
231  (foreign-lambda int "gnu_readline_append_history" c-string))
232
233(define set-bounce-ms
234  (foreign-lambda* void ((int time)) "gnu_readline_bounce_ms = time;"))
235
236;; (gnu-readline-truncate-history <filename-or-false> <numlines>) -> 0 succ, errno fail
237(define truncate-history
238  (foreign-lambda int "history_truncate_file" c-string int))
239
240(define history-newlines
241  (foreign-lambda int "gnu_history_new_lines"))
242
243(define %add-history%
244  (foreign-lambda void "add_history" c-string))
245
246(define (%remove-history% #!optional pos)
247  (let ((pos (or pos (history-position))))
248    ((foreign-lambda void "safely_remove_history" int) pos)))
249
250(define (current-history-line)
251  ((foreign-lambda c-string "current_history_line")))
252
253(define (search-history-starts-with string direction)
254  (let ((success
255         ((foreign-lambda int "history_search_prefix" c-string int) string direction)))
256    (if (= success -1)
257        #f
258        (current-history-line))))
259
260(define (search-history-from-position string direction position)
261  (let ((result
262         ((foreign-lambda int "history_search_pos" c-string int int) string direction position)))
263    (if (= result -1)
264        #f
265        result)))
266
267(define (search-history string direction)
268  (let ((offset
269         ((foreign-lambda int "history_search" c-string int) string direction)))
270    (if (= offset -1)
271        #f
272        (current-history-line))))
273
274(define (search-history-backward string)
275  (search-history string -1))
276(define (search-history-forward string)
277  (search-history string 1))
278
279(define (search-history-starts-with-backward string)
280  (search-history-starts-with string -1))
281(define (search-history-starts-with-forward string)
282  (search-history-starts-with string 1))
283
284(define history-list-length
285  (foreign-lambda int "gnu_history_list_length"))
286
287(define (last-history-line #!optional as-string script)
288  (let ((cmd-string ((foreign-lambda c-string "last_history_line" int int) 0 (if script 1 0))))
289    (if as-string
290        cmd-string
291        (##sys#read-from-string cmd-string))))
292
293(define (eval-last-history-line #!optional script)
294  (if (getkv session #:verify-history-expansions)
295      ((foreign-lambda void "insert_last_history_line" int int int) 1 (if script 1 0) 0)
296      ((foreign-lambda void "run_last_history_line" int int) 1 (if script 1 0))))
297
298#| the underlying c-function works, but the scheme binding to said function is buggy.
299I just can't seem to get this function to do what I want it to do. :(
300it's supposed to take a string of history entries and transform it like so:
301
302"a\nb\nc\nd" -> ((1 . "a") (2 . "b") (3 . "c") (4 . "d"))
303
304|#
305
306(define (history-list)
307  `(,@(string-split ((foreign-lambda c-string* "gnu_history_list")) "\n")))
308
309;; (gnu-history-position) -> current history position within history_list
310;; (set! (history-position) pos) -> sets the current history position
311(define (history-position #!optional pos)
312  (if pos
313      ((foreign-lambda int "history_set_pos" int) pos)
314      ((foreign-lambda int "where_history"))))
315(set! (setter history-position) (lambda (pos) ((foreign-lambda bool "history_set_pos" int) pos)))
316
317;; Useful...
318(define parse-and-bind
319  (foreign-lambda int "rl_parse_and_bind" c-string))
320
321                                        ; paren-bouncing support (comes with batteries included)
322                                        ; XXX however, it doesn't work with LISP.
323                                        ;(parse-and-bind "set blink-matching-paren on")
324
325
326;; Handler for the command history file
327(define (install-history-file #!optional homedir filename nlines)
328  (let* ((fname (or filename ".csi_history"))
329         (histfile
330          (if homedir
331              (string-append homedir "/" fname)
332              (string-append (or (get-environment-variable "HOME") ".")
333                             "/"
334                             fname))))
335    (define (hook param)
336      (param (let ((next (param)))
337               (lambda args
338                 ;(gnu-readline-write-history filename)
339                 (and (not (file-exists? histfile))
340                      (file-close (file-open histfile (+ open/append open/creat open/excl) (+ perm/irusr perm/iwusr))))
341                 (and (getkv session #:save-history-on-exit) (append-history histfile))
342                 (apply next args)))))
343    (if (pair? nlines)
344        (set! nlines (car nlines))
345        (set! nlines 1000))
346    (if nlines
347        (truncate-history histfile nlines))
348    (and (getkv session #:load-history-file) (read-history histfile))
349    (hook exit-handler)
350    (hook implicit-exit-handler)))
351
352;; Prompt2 is displayed when there are still open parens, this just makes a reasonable one
353(define (make-prompt2 prompt)
354  (let ((len (string-length prompt)))
355    (case len
356      ((0) "")
357      ((1) ">")
358      ((2) "> ")
359      (else (conc (make-string (- len 2) #\-) "> ")))))
360
361
362;; Creates a port that reads using readline
363(define (make-readline-port #!optional prompt prompt2)
364  (let ((buffer   "")
365        (pos      0)
366        (p1       prompt)
367        (p2       prompt2) ;; removes the weird second prompt
368        (handle   #t))
369    (letrec ((char-ready?
370              (lambda ()
371                (< pos (string-length buffer))))
372             (get-next-char!
373              (lambda ()
374                (cond ((not buffer)
375                       #!eof)
376                      ((char-ready?)
377                       (let ((ch   (string-ref buffer pos)))
378                         (set! pos (+ 1 pos))
379                         ch))
380                      (else
381                       (set! pos 0)
382                       (set! buffer
383                         (let* ((prompt
384                                 (or prompt
385                                     ((##readline#repl-prompt))))
386                                (prompt2   (make-prompt2 prompt)))
387                           (readline prompt prompt2)))
388                       (if (string? buffer)
389                           (set! buffer (string-append buffer "\n")))
390                       (get-next-char!))))))
391      (set! handle (lambda (s)
392                     (print-call-chain)
393                     (set! pos 0)
394                     (set! buffer "")
395                     ((foreign-lambda void
396                                      "gnu_readline_signal_cleanup"))
397                     (##sys#user-interrupt-hook)))
398      (set-signal-handler! signal/int handle)
399      (let ((p   (make-input-port
400                  get-next-char!
401                  char-ready?
402                  (lambda ()
403                    (set-signal-handler! signal/int #f)
404                    'closed-gnu-readline-port))))
405        (set-port-name! p "(gnu-readline)")
406        p))))
407
408#| Leagcy Bindings |#
409(define legacy-bindings
410  '((gnu-readline-readline
411     readline#readline)
412
413    (%gnu-readline-signal-cleanup
414     readline#%signal-cleanup)
415
416    (gnu-readline-clear-history
417     readline#clear-history)
418
419    (gnu-readline-read-history
420     readline#read-history)
421
422    (gnu-readline-write-history
423     readline#write-history)
424
425    (gnu-readline-append-history
426     readline#append-history)
427
428    (gnu-readline-truncate-history
429     readline#truncate-history)
430
431    (gnu-history-new-lines
432     readline#history-newlines)
433
434    (gnu-readline-parse-and-bind
435     readline#parse-and-bind)
436
437    (gnu-readline-set-bounce-ms
438     readline#set-bounce-ms)
439
440    (gnu-history-install-file-manager
441     (lambda (filename . nlines)
442       (readline#install-history-file #f filename nlines)))
443
444    (make-gnu-readline-port
445     readline#make-readline-port)
446
447    (gnu-readline-completions
448     readline#completions)
449    ))
450
451(define (use-legacy-bindings)
452  (and (map (lambda (a) (eval a))
453            (do ((lst legacy-bindings (cdr lst))
454                 (new-lst '() (append new-lst (list `(define ,(caar lst) ,(cadar lst))))))
455                ((null? lst) new-lst)))
456       (void)))
457;;;;;;;; Tab Completion ;;;;;;;;
458
459;; Borrowed from the oblist egg
460(define find-symbol-table (foreign-lambda c-pointer "C_find_symbol_table" c-string))
461(define enum-symbols! (foreign-lambda scheme-object "C_enumerate_symbols" c-pointer scheme-object))
462
463;; Globally defined enumeration state (callbacks can't be closures)
464(define enum-funcs '())
465
466;; Creates a list of closures that enumerate anything the user would want to type
467(define (create-symbol-ef word)
468  (let ((global-symbol-index (cons -1 '()))
469        (global-symbol-pointer (find-symbol-table ".")))
470    (lambda ()
471      (let loop ()
472        (let ((symb (enum-symbols! global-symbol-pointer
473                                   global-symbol-index)))
474          (cond ((not symb)
475                 "")
476                ((not (##sys#symbol-has-toplevel-binding? symb))
477                 (loop))
478                (else
479                 (let ((str (##sys#symbol->qualified-string symb)))
480                   ;; Possibly undo the mangling of keywords
481                   (if (not (substring=? "###" str))
482                       str
483                       (string-append (substring str 3) ":"))))))))))
484
485;; R5RS keywords (including some special forms not included in above)
486(define (create-static-ef word)
487  (let ((index -1)
488        (v-len (vector-length static-keywords)))
489    (lambda ()
490      (set! index (+ 1 index))
491      (if (not (>= index v-len))
492          (vector-ref static-keywords index)
493          ""))))
494
495;; Macros (thanks to Kon Lovett for suggesting ##sys#macro-environment)
496(define (create-macro-ef word)
497  (let ((index -1))
498    (lambda ()
499      (let ((macro-env (##sys#macro-environment)))
500        (let loop ()
501          (set! index (+ 1 index))
502          (cond ((>= index (length macro-env))
503                 "")
504                (else
505                 (let ((ref (list-ref macro-env index)))
506                   (if (null? ref)
507                       (loop)
508                       (symbol->string (car ref)))))))))))
509
510;; handling filename completion
511(define (turn-on-filenames)
512  (set! filename-completion 1))
513
514(define (create-file-ef word)
515  (turn-on-filenames)
516  (let ((files (glob (string-append word "*"))))
517    (lambda ()
518      (if (null? files) ""
519          (let ((current (car files)))
520            (set! files (cdr files))
521            current)))))
522
523(define completions
524  (make-parameter
525   (list
526    (cons 'macros create-macro-ef)
527    (cons 'statics create-static-ef)
528    (cons 'symbols create-symbol-ef))))
529
530(define quoted-completions
531  (make-parameter
532   (list
533    (cons 'files create-file-ef))))
534
535;; This is the completion function called by readline
536;; It's called repeatedly until it returns an empty string
537;; (lambda'd to stop the compiler complaining about unused global var)
538((lambda ()
539   (define-external (gnu_readline_scm_complete (c-string word) (int len) (int state)) scheme-object
540     ;; If state is zero, init enumeration funcs.  Don't try to complete an empty string...
541                                        ;(print is-quoted?)
542     (when (zero? state)
543           (if (not (zero? len))
544               (set! enum-funcs (choose-completion-procs word))
545               ""))
546     ;; Call the enumeration funcs, discarding the ones that are done
547     (let loop ()
548       (if (null? enum-funcs)
549           ""
550           (let ((result ((car enum-funcs))))
551             (cond ((equal? result "")
552                    (set! enum-funcs (cdr enum-funcs))
553                    (loop))
554                   ((substring=? word result 0 0 len)
555                    result) ;; Return only ones that are a substring of the word typed
556                   (else (loop)))))))))
557
558;; This function simply chooses which completion type is appropriate
559;; and then gets those procedures ready.
560(define (choose-completion-procs word)
561  (map
562   (lambda (pair) ((cdr pair) word))
563   (if (= 34 is-quoted?)
564       (quoted-completions)
565       (completions))))
566
567;; Things that will always be there...
568(define static-keywords (vector
569                         ;;; R5RS
570                         "abs" "acos" "and" "angle" "append" "apply" "asin"
571                         "assoc" "assq" "assv" "atan" "begin" "boolean?"
572                         "caar" "cadr" "call-with-current-continuation"
573                         "call-with-input-file" "call-with-output-file"
574                         "call-with-values" "car" "case" "cdddar" "cddddr"
575                         "cdr" "ceiling" "char->integer" "char-alphabetic?"
576                         "char-ci<=?" "char-ci<?" "char-ci=?" "char-ci>=?"
577                         "char-ci>?" "char-downcase" "char-lower-case?"
578                         "char-numeric?" "char-ready?" "char-upcase"
579                         "char-upper-case?" "char-whitespace?" "char<=?"
580                         "char<?" "char=?" "char>=?" "char>?" "char?"
581                         "close-input-port" "close-output-port" "complex?"
582                         "cond" "cons" "cos" "current-input-port"
583                         "current-output-port" "define" "define-syntax"
584                         "delay" "denominator" "display" "do" "dynamic-wind"
585                         "else" "eof-object?" "eq?" "equal?" "eqv?" "eval"
586                         "even?" "exact->inexact" "exact?" "exp" "expt"
587                         "floor" "for-each" "force" "gcd" "if" "imag-part"
588                         "inexact->exact" "inexact?" "input-port?"
589                         "integer->char" "integer?" "interaction-environment"
590                         "lambda" "lcm" "length" "let" "let*" "let-syntax"
591                         "letrec" "letrec-syntax" "list" "list->string"
592                         "list->vector" "list-ref" "list-tail" "list?" "load"
593                         "log" "magnitude" "make-polar" "make-rectangular"
594                         "make-string" "make-vector" "map" "max" "member"
595                         "memq" "memv" "min" "modulo" "negative?" "newline"
596                         "not" "null-environment" "null?" "number->string"
597                         "number?" "numerator" "odd?" "open-input-file"
598                         "open-output-file" "or" "output-port?" "pair?"
599                         "peek-char" "port?" "positive?" "procedure?"
600                         "quasiquote" "quote" "quotient" "rational?"
601                         "rationalize" "read" "read-char" "real-part"
602                         "real?" "remainder" "reverse" "round"
603                         "scheme-report-environment" "set!" "set-car!"
604                         "set-cdr!" "setcar" "sin" "sqrt" "string"
605                         "string->list" "string->number" "string->symbol"
606                         "string-append" "string-ci<=?" "string-ci<?"
607                         "string-ci=?" "string-ci>=?" "string-ci>?"
608                         "string-copy" "string-fill!" "string-length"
609                         "string-ref" "string-set!" "string<=?" "string<?"
610                         "string=?" "string>=?" "string>?" "string?"
611                         "substring" "symbol->string" "symbol?"
612                         "syntax-rules" "tan" #| "transcript-off" ; not implemented
613                         "transcript-on" |# "truncate" "values" "vector"
614                         "vector->list" "vector-fill!" "vector-length"
615                         "vector-ref" "vector-set!" "vector?"
616                         "with-input-from-file" "with-output-to-file"
617                         "write" "write-char" "zero?"
618                                        ; csi commands
619                         ",?" ",p" ",d" ",du" ",dur" ",q" ",l" ",ln" ",r"
620                         ",s" ",tr" ",utr" ",t" ",x"
621                                        ; rl commands
622                         ",rl-clh" ",rl-savhist" ",rl-rec" ",rl-!!"
623                         ",rl-rd" ",rl-emacs" ",rl-vi"
624                         ))
625
626(define (variables #!optional inputrc-format?)
627  ((foreign-lambda void "rl_variable_dumper" int) (or inputrc-format? 0)))
628
629)
630
631(define-inline (pad str-1 str-2) (string-append str-1
632                                                "           "
633                                                str-2))
634
635(toplevel-command 'rl-clh (lambda ()
636                            (readline#clear-history))
637                  (pad ",rl-clh" "Clear this session's history"))
638
639(toplevel-command 'rl-savhist (lambda ()
640                                (let ((value (getkv readline#session #:save-history-on-exit)))
641                                  (and (setkv! readline#session #:save-history-on-exit (not value))
642                                       (not value))))
643                  ",rl-savhist       Enable/disable saving this session's history on exit (enabled by default)")
644
645(toplevel-command 'rl-rec (lambda ()
646                            (let ((value (getkv readline#session #:record-history)))
647                              (and (setkv! readline#session #:record-history (not value))
648                                   (not value))))
649                  (pad ",rl-rec" "Enable/disable recording history for this session (enabled by default)"))
650
651(toplevel-command 'rl-rd (lambda ()
652                           (readline#read-history (irregex-replace/all
653                                                   "~"
654                                                   (read-line)
655                                                   (get-environment-variable "HOME"))))
656                  (pad ",rl-rd" " Read history file into this session"))
657
658(toplevel-command 'rl-!! readline#eval-last-history-line)
659
660(toplevel-command 'rl-vi (lambda ()
661                           (readline#parse-and-bind "set editing-mode vi")))
662
663(toplevel-command 'rl-emacs (lambda ()
664                              (readline#parse-and-bind "set editing-mode emacs")))
665; TODO add rl-history-grep
666;(toplevel-command 'rl-hgrp
Note: See TracBrowser for help on using the repository browser.