Changeset 7282 in project


Ignore:
Timestamp:
01/06/08 05:43:42 (12 years ago)
Author:
ashinn
Message:

Checking in version 0.6.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/scheme-complete.el

    r6828 r7282  
    2828;;; (add-hook 'scheme-mode-hook
    2929;;;   (lambda ()
    30 ;;;     (setq eldoc-info-function 'scheme-get-current-symbol-info)
     30;;;     (make-local-variable 'eldoc-documentation-function)
     31;;;     (setq eldoc-documentation-function 'scheme-get-current-symbol-info)
    3132;;;     (eldoc-mode)))
    3233;;;
     34;;; There's a single custom variable, default-scheme-implementation,
     35;;; which you can use to specify your preferred implementation when we
     36;;; can't infer it from the source code.
     37;;;
    3338;;; That's all there is to it.
    3439
    3540;;; History:
    36 ;;;   0.4: 2007/11/14 - silly bugfixe plus better repo env support
     41;;;   0.6: 2008/01/06 - more bugfixes (merry christmas)
     42;;;   0.5: 2008/01/03 - handling internal defines, records, smarter
     43;;;                     parsing
     44;;;   0.4: 2007/11/14 - silly bugfix plus better repo env support
    3745;;;                     for searching chicken and gauche modules
    3846;;;   0.3: 2007/11/13 - bugfixes, better inference, smart strings
     
    17101718    ))
    17111719
     1720;; by default chicken has a single top-level namespace, so we want to
     1721;; handle recursive imports
    17121722(defvar *scheme-chicken-deps*
    17131723  '((lolevel extras)
     
    17191729    (args srfi-37)
    17201730    (array-lib srfi-1 srfi-4 lolevel miscmacros)
     1731    (awk regex)
     1732    (bloom-filter
     1733     srfi-1 utils lolevel
     1734     iset message-digest hash-utils lookup-table mathh-int
     1735     misc-extn-control misc-extn-numeric misc-extn-record)
     1736    (binary-tree srfi-1 misc-extn-record)
     1737    (box lolevel)
     1738    (cgi-util extras input-parse)
     1739    (charplot array-lib array-lib-hof)
     1740    (charconv regex posix)
     1741    (content-type regex format-modular)
    17211742    ))
    17221743
     1744;; another big table - consider moving to a separate file
    17231745(defvar *scheme-implementation-exports*
    17241746  '((chicken
     
    27252747(defun chicken-available-modules (&optional sym)
    27262748  (append
    2727    (mapcar 'symbol-name (mapcar 'car *scheme-chicken-modules*))
     2749   (mapcar #'symbol-name (mapcar #'car *scheme-chicken-modules*))
     2750   (mapcar
     2751    #'file-name-sans-extension
     2752    (directory-files "." nil ".*\\.scm$" t))
    27282753   (append-map
    27292754    #'(lambda (dir)
    27302755        (mapcar
    2731          'file-name-sans-extension
     2756         #'file-name-sans-extension
    27322757         (directory-files dir nil ".*\\.\\(so\\|scm\\)$" t)))
    27332758    *chicken-repo-dirs*)))
     
    27552780        (other-dirs
    27562781         (remove-if-not
    2757           #'file-directory-p
     2782          #'(lambda (d) (and (not (equal d "")) (file-directory-p d)))
    27582783          (split-string (or (getenv "GAUCHE_LOAD_PATH") "") ":"))))
    27592784    (mapcar
     
    29042929
    29052930(defun goto-next-top-level ()
    2906   (or (re-search-forward "^(" nil t)
    2907       (goto-char (point-max))))
     2931  (let ((here (point)))
     2932    (or (ignore-errors (end-of-defun) (end-of-defun)
     2933                       (beginning-of-defun)
     2934                       (not (eq here (point))))
     2935        (progn (forward-char) (re-search-forward "^(" nil t))
     2936        (goto-char (point-max)))))
    29082937
    29092938;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    29102939;; variable extraction
     2940
     2941(defun sexp-type-at-point (&optional env)
     2942  (case (char-syntax (char-after))
     2943    ((?\()
     2944     (forward-char 1)
     2945     (if (eq ?w (char-syntax (char-after)))
     2946         (let ((op (scheme-symbol-at-point)))
     2947           (cond
     2948            ((eq op 'lambda)
     2949             (let ((params
     2950                    (nth-sexp-at-point 1)))
     2951               `(lambda ,params)))
     2952            (t
     2953             (let ((spec (scheme-env-lookup env op)))
     2954               (and spec
     2955                    (consp (cadr spec))
     2956                    (eq 'lambda (caadr spec))
     2957                    (cddadr spec)
     2958                    (car (cddadr spec)))))))
     2959       nil))
     2960    ((?\")
     2961     'string)
     2962    ((?\w)
     2963     (if (string-match "[0-9]" (string (char-after)))
     2964         'number
     2965       nil))
     2966    (t
     2967     nil)))
    29112968
    29122969(defun let-vars-at-point (&optional env)
     
    29192976          (forward-char 1)
    29202977          (if (eq ?w (char-syntax (char-after)))
    2921               (let ((sym (scheme-symbol-at-point)))
    2922                 (beginning-of-next-sexp)
    2923                 (let ((c (char-syntax (char-after))))
    2924                   (case c
    2925                     ((?\")
    2926                      (push (list sym 'string) vars))
    2927                     ((?\()
    2928                      (forward-char 1)
    2929                      (if (eq ?w (char-syntax (char-after)))
    2930                          (let ((op (scheme-symbol-at-point)))
    2931                            (cond
    2932                             ((eq op 'lambda)
    2933                              (let ((params
    2934                                     (nth-sexp-at-point 1)))
    2935                                (push (list sym `(lambda ,params)) vars)))
    2936                             (t
    2937                              (let ((spec (scheme-env-lookup env op)))
    2938                                (if (and spec
    2939                                         (consp (cadr spec))
    2940                                         (eq 'lambda (caadr spec))
    2941                                         (cddadr spec))
    2942                                    (push (list sym (car (cddadr spec))) vars)
    2943                                  (push (list sym) vars))))))
    2944                        (push (list sym) vars)))
    2945                     (t
    2946                      (push (list sym) vars))))))))
     2978              (let* ((sym (scheme-symbol-at-point))
     2979                     (type (ignore-errors
     2980                             (beginning-of-next-sexp)
     2981                             (sexp-type-at-point env))))
     2982                (push (if type (list sym type) (list sym)) vars)))))
    29472983      (or (ignore-errors (progn (beginning-of-next-sexp) t))
    29482984          (goto-char end)))
     
    29843020;; (setq *current-scheme-implementation* whatever)
    29853021
     3022(defgroup scheme-complete nil
     3023  "Smart tab completion"
     3024  :group 'scheme)
     3025
     3026(defcustom default-scheme-implementation nil
     3027  "Default scheme implementation to provide completion for
     3028when scheme-complete can't infer the current implementation."
     3029  :type 'symbol
     3030  :group 'scheme-complete)
     3031
    29863032(defvar *current-scheme-implementation* nil)
    29873033(make-variable-buffer-local '*current-scheme-implementation*)
    29883034
    2989 (defvar *default-scheme-implementation* 'chicken)
    2990 
     3035;; most implementations use their name as the script name
    29913036(defvar *scheme-interpreter-alist*
    29923037  '(("csi" . chicken)
     
    30143059                  'mzscheme))))))
    30153060  (or *current-scheme-implementation*
    3016       *default-scheme-implementation*))
     3061      default-scheme-implementation))
    30173062
    30183063;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    30203065(defun current-local-vars (&optional env)
    30213066  (let ((vars '())
    3022         (limit (save-excursion (beginning-of-defun) (+ (point) 1))))
     3067        (limit (save-excursion (beginning-of-defun) (+ (point) 1)))
     3068        (start (point))
     3069        (scan-internal))
    30233070    (save-excursion
    30243071      (while (> (point) limit)
     
    30323079                   (eq ?\( (char-syntax (char-before (point))))
    30333080                   (eq ?w (char-syntax (char-after (point)))))
     3081          (setq scan-internal t)
    30343082          (let ((sym (scheme-symbol-at-point)))
    3035             ;; XXXX handle internal defines
    30363083            (case sym
    30373084              ((lambda)
     
    30763123                             vars)))
    30773124              (t
    3078                (when (string-match "^define\\(-.*\\)?" (symbol-name sym))
    3079                  (setq vars
    3080                        (append (mapcar #'list (flatten (nth-sexp-at-point 1)))
    3081                                vars)))))
    3082             ))))
     3125               (if (string-match "^define\\(-.*\\)?" (symbol-name sym))
     3126                   (let ((defs (save-excursion
     3127                                 (backward-char)
     3128                                 (scheme-extract-definitions))))
     3129                     (setq vars
     3130                           (append (append-map
     3131                                    #'(lambda (x)
     3132                                        (and (consp (cdr x))
     3133                                             (consp (cadr x))
     3134                                             (eq 'lambda (caadr x))
     3135                                             (mapcar #'list
     3136                                                     (flatten (cadadr x)))))
     3137                                    defs)
     3138                                   defs
     3139                                   vars)))
     3140                 (setq scan-internal nil))))
     3141            ;; check for internal defines
     3142            (when scan-internal
     3143              (ignore-errors
     3144                (save-excursion
     3145                  (forward-sexp
     3146                   (+ 1 (if (numberp scan-internal) scan-internal 2)))
     3147                  (backward-sexp)
     3148                  (if (< (point) start)
     3149                      (setq vars (append (current-scheme-definitions) vars))
     3150                    ))))))))
    30833151    (reverse vars)))
    30843152
     
    31943262    imports))
    31953263
    3196 (defun name-of-define (sexp)
    3197   (if (consp (cadr sexp)) (caadr sexp) (cadr sexp)))
    3198 
    3199 (defun scheme-top-definitions (sexp)
    3200   (let ((defs '())
    3201         (stack (list sexp)))
    3202     (while (consp stack)
    3203       (let ((sexp (pop stack)))
    3204         (when (and (consp sexp) (consp (cdr sexp)))
    3205           (case (car sexp)
    3206             ((define-syntax defmacro define-macro)
    3207              (push (list (name-of-define sexp) '(syntax)) defs))
    3208             ((define define-inline define-constant defun)
    3209              (push (list (name-of-define sexp)
    3210                          (if (or (eq 'defun (car sexp))
    3211                                  (consp (cadr sexp))
    3212                                  (and (consp (caddr sexp))
    3213                                       (eq 'lambda (caaddr sexp))))
    3214                              (cond
    3215                               ((eq 'defun (car sexp))
    3216                                `(lambda ,(caddr sexp)))
    3217                               ((consp (cadr sexp))
    3218                                `(lambda ,(cdadr sexp)))
    3219                               (t
    3220                                `(lambda ,(car (cdaddr sexp)))))
    3221                              'object))
    3222                    defs))
    3223             ((defvar define-class)
    3224              (push (list (name-of-define sexp) 'non-procedure) defs))
    3225             ((define-record-type)
    3226              (setq defs
    3227                    (cons (list (caddr sexp) 'procedure)
    3228                          (cons (list (cadddr sexp) 'procedure)
    3229                                (append (append-map #'(lambda (x)
    3230                                                    (list (cdr x) 'procedure))
    3231                                                (cdddr sexp))
    3232                                        defs)))))
    3233             ((begin progn)
    3234              (setq stack (append (cdr sexp) stack)))
    3235             ((cond-expand)
    3236              (setq stack (append-map #'cdr (cdr sexp))))
    3237             (t
    3238              '())))))
    3239     defs))
    3240 
     3264;; we should be just inside the opening paren of an expression
     3265(defun scheme-name-of-define ()
     3266  (save-excursion
     3267    (beginning-of-next-sexp)
     3268    (if (eq ?\( (char-syntax (char-after)))
     3269        (forward-char))
     3270    (and (memq (char-syntax (char-after)) '(?\w ?\_))
     3271         (scheme-symbol-at-point))))
     3272
     3273(defun scheme-type-of-define ()
     3274  (save-excursion
     3275    (beginning-of-next-sexp)
     3276    (cond
     3277     ((eq ?\( (char-syntax (char-after)))
     3278      `(lambda ,(cdr (nth-sexp-at-point 0))))
     3279     (t
     3280      (beginning-of-next-sexp)
     3281      (sexp-type-at-point)))))
     3282
     3283;; we should be at the opening paren of an expression
     3284(defun scheme-extract-definitions (&optional env)
     3285  (save-excursion
     3286    (let ((sym (ignore-errors (and (eq ?\( (char-syntax (char-after)))
     3287                                   (progn (forward-char)
     3288                                          (scheme-symbol-at-point))))))
     3289      (case sym
     3290        ((define-syntax defmacro define-macro)
     3291         (list (list (scheme-name-of-define) '(syntax))))
     3292        ((define define-inline define-constant define-primitive defun)
     3293         (let ((name (scheme-name-of-define))
     3294               (type (scheme-type-of-define)))
     3295           (list (if type (list name type) (list name)))))
     3296        ((defvar define-class)
     3297         (list (list (scheme-name-of-define) 'non-procedure)))
     3298        ((define-record)
     3299         (backward-char)
     3300         (ignore-errors
     3301           (let* ((sexp (nth-sexp-at-point 0))
     3302                  (name (symbol-name (cadr sexp))))
     3303             `((,(intern (concat name "?")) (lambda (obj) boolean))
     3304               (,(intern (concat "make-" name)) (lambda ,(cddr sexp) ))
     3305               ,@(append-map
     3306                  #'(lambda (x)
     3307                      `((,(intern (concat name "-" (symbol-name x)))
     3308                         (lambda (non-procedure)))
     3309                        (,(intern (concat name "-" (symbol-name x) "-set!"))
     3310                         (lambda (non-procedure val) undefined))))
     3311                  (cddr sexp))))))
     3312        ((define-record-type)
     3313         (backward-char)
     3314         (ignore-errors
     3315           (let ((sexp (nth-sexp-at-point 0)))
     3316             `((,(caaddr sexp) (lambda ,(cdaddr sexp)))
     3317               (,(cadddr sexp) (lambda (obj)))
     3318               ,@(append-map
     3319                  #'(lambda (x)
     3320                      (if (consp x)
     3321                          (if (consp (cddr x))
     3322                              `((,(cadr x) (lambda (non-procedure)))
     3323                                (,(caddr x)
     3324                                 (lambda (non-procedure val) undefined)))
     3325                            `((,(cadr x) (lambda (non-procedure)))))))
     3326                  (cddddr sexp))))))
     3327        ((begin progn)
     3328         (forward-sexp)
     3329         (current-scheme-definitions))
     3330        (t
     3331         '())))))
     3332
     3333;; a little more liberal than -definitions, we try to scan to a new
     3334;; top-level form (i.e. a line beginning with an open paren) if
     3335;; there's an error during normal sexp movement
    32413336(defun current-scheme-globals ()
    32423337  (let ((globals '()))
    32433338    (save-excursion
    32443339      (goto-char (point-min))
     3340      (or (ignore-errors (end-of-defun) (beginning-of-defun) t)
     3341          (re-search-forward "^(" nil t)
     3342          (goto-char (point-max)))
    32453343      (while (not (eobp))
    3246         (if (ignore-errors (progn (forward-sexp) t))
    3247             (setq globals
    3248                   ;; XXXX avoid reading whole top-level form
    3249                   (append (scheme-top-definitions (nth-sexp-at-point 0))
    3250                           globals))
    3251           (goto-next-top-level))))
     3344        (setq globals
     3345              (append (scheme-extract-definitions) globals))
     3346        (goto-next-top-level)))
    32523347    globals))
     3348
     3349;; for internal defines, etc.
     3350(defun current-scheme-definitions (&optional enclosing-end)
     3351  (let ((defs '())
     3352        (end (or enclosing-end (point-max))))
     3353    (save-excursion
     3354      (while (< (point) end)
     3355        (let ((new-defs (scheme-extract-definitions)))
     3356          (cond
     3357           (new-defs
     3358             (setq defs (append new-defs defs))
     3359             (or (ignore-errors (beginning-of-next-sexp) t)
     3360                 (goto-char end)))
     3361           (t ;; non-definition form, stop scanning
     3362            (goto-char end))))))
     3363    defs))
    32533364
    32543365(defun scheme-module-exports (mod)
     
    33213432
    33223433;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     3434;; This is rather complicated because we to auto-generate docstring
     3435;; summaries from the type information, which means inferring various
     3436;; types from common names.  The benefit is that you don't have to
     3437;; input the same information twice, and can often cut&paste&munge
     3438;; procedure descriptions from the original documentation.
    33233439
    33243440(defun scheme-translate-type (type)
     
    33743490      (cond
    33753491        ((eq :optional (car spec))
    3376          (decf i))
    3377         ((eq '|...| (cadr spec))
     3492         (if (and (= i (- pos 1)) (consp (cdr spec)))
     3493             (setq type (cadr spec)))
     3494         (setq i pos))
     3495        ((and (consp (cdr spec)) (eq '|...| (cadr spec)))
    33783496         (setq type (car spec))
    33793497         (setq spec nil)))
     
    33813499      (incf i))
    33823500    (if (and (not type) (= i pos))
    3383         (setq type (car (remove ':optional spec))))
     3501        (setq type (if (consp spec) (car spec) spec)))
    33843502    (if type
    33853503        (setq type (scheme-translate-type type)))
     
    35033621               (t nil))))))
    35043622
     3623(defun nth* (n ls)
     3624  (while (and (consp ls) (> n 0))
     3625    (setq n (- n 1)
     3626          ls (cdr ls)))
     3627  (and (consp ls) (car ls)))
     3628
    35053629(defun scheme-smart-complete (&optional arg)
    35063630  (interactive "P")
     
    35473671           (eq 'lambda (car outer-type))
    35483672           (not (zerop outer-pos))
    3549            (nth outer-pos (cadr outer-type))
     3673           (nth* outer-pos (cadr outer-type))
    35503674           (zerop inner-pos))
    35513675      (let ((ret-type (scheme-lookup-type (cadr outer-type) outer-pos)))
     
    36533777(defun scheme-get-current-symbol-info ()
    36543778  (let* ((sym (eldoc-current-symbol))
    3655          (fnsym (eldoc-fnsym-in-current-sexp))
     3779         (fnsym0 (eldoc-fnsym-in-current-sexp))
     3780         (fnsym (if (consp fnsym0) (car fnsym0) fnsym0))
    36563781         (env (save-excursion
    36573782                (if (scheme-in-string-p) (beginning-of-string))
Note: See TracChangeset for help on using the changeset viewer.