Changeset 14521 in project


Ignore:
Timestamp:
05/04/09 05:00:46 (10 years ago)
Author:
Alex Shinn
Message:

updating to 0.8.6

File:
1 edited

Legend:

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

    r13452 r14521  
    2121;;; (eval-after-load 'scheme
    2222;;;   '(define-key scheme-mode-map "\t" 'scheme-complete-or-indent))
     23;;;
     24;;;   Note: the completion uses a somewhat less common style than
     25;;;   typically found in other modes.  The first tab will complete the
     26;;;   longest prefix common to all possible completions.  The second
     27;;;   tab will show a list of those completions.  Subsequent tabs will
     28;;;   scroll that list.  You can't use the mouse to select from the
     29;;;   list - when you see what you want, just type the next one or
     30;;;   more characters in the symbol you want and hit tab again to
     31;;;   continue completing it.  Any key typed will bury the completion
     32;;;   list.  This ensures you can achieve a completion with the
     33;;;   minimal number of keystrokes without the completions window
     34;;;   lingering and taking up space.
    2335;;;
    2436;;; If you use eldoc-mode (included in Emacs), you can also get live
     
    4759
    4860;;; History:
     61;;; 0.8.6: 2009/05/03 - fixing support for chicken 4 w/ unbalanced parens
     62;;; 0.8.5: 2009/04/30 - full support for chicken 4, fixed bug in caching
     63;;; 0.8.4: 2008/12/26 - numerous small bugfixes (Merry Christmas!)
    4964;;; 0.8.3: 2008/10/06 - smart indent, inferring types from imported modules,
    50 ;;                      optionally caching exports, chicken 4 support
     65;;;                     optionally caching exports, chicken 4 support
    5166;;; 0.8.2: 2008/07/04 - both TAB and M-TAB scroll results (thanks Peter Bex),
    5267;;;                     better MATCH handling, fixed SRFI-55, other bugfixes
    5368;;; 0.8.1: 2008/04/17 - great renaming, everthing starts with `scheme-'
    54 ;;                      also, don't scan imported modules multiple times
     69;;;                     also, don't scan imported modules multiple times
    5570;;;   0.8: 2008/02/08 - several parsing bugfixes on unclosed parenthesis
    5671;;;                       (thanks to Kazushi NODA)
     
    284299    (procedure? (lambda (obj) bool) "returns #t iff OBJ is a procedure")
    285300    (apply (lambda ((lambda obj a) obj \.\.\.) a) "procedure application")
    286     (map (lambda ((lambda obj a) obj \.\.\.) (list a)) "a new list of PROC applied to every element of LIST")
     301    (map (lambda ((lambda (obj1 . obj2) a) list \.\.\.) (list a)) "a new list of PROC applied to every element of LIST")
    287302    (for-each (lambda ((lambda obj a) obj \.\.\.) undefined) "apply PROC to each element of LIST in order")
    288303    (force (lambda (promise) obj) "force the delayed value of PROMISE")
     
    373388    (unzip4 (lambda (list) list))
    374389    (unzip5 (lambda (list) list))
    375     (count (lambda (procedure list \.\.\.) n))
    376     (fold (lambda ((lambda obj a) object list \.\.\.) a))
     390    (count (lambda ((lambda (obj1 . obj2)) list \.\.\.) n))
     391    (fold (lambda ((lambda (obj1 obj2 . obj3) a) object list \.\.\.) a))
    377392    (unfold (lambda (procedure procedure procedure object :optional procedure) obj))
    378393    (pair-fold (lambda ((lambda obj a) object list \.\.\.) a))
    379     (reduce (lambda ((lambda obj a) object list \.\.\.) a))
    380     (fold-right (lambda ((lambda obj a) object list \.\.\.) a))
     394    (reduce (lambda ((lambda (obj1 obj2 . obj3) a) object list \.\.\.) a))
     395    (fold-right (lambda ((lambda (obj1 obj2 . obj3) a) object list \.\.\.) a))
    381396    (unfold-right (lambda (procedure procedure procedure object :optional object) obj))
    382     (pair-fold-right (lambda ((lambda obj a) object list \.\.\.) a))
    383     (reduce-right (lambda ((lambda obj a) object list \.\.\.) a))
    384     (append-map (lambda (procedure list \.\.\.) list))
    385     (append-map! (lambda (procedure list \.\.\.) list))
    386     (map! (lambda (procedure list \.\.\.) list))
    387     (pair-for-each (lambda (procedure list \.\.\.) undefined))
    388     (filter-map (lambda (procedure list \.\.\.) list))
    389     (map-in-order (lambda (procedure list \.\.\.) list))
    390     (filter (lambda (procedure list) list))
    391     (partition (lambda (procedure list) list))
    392     (remove (lambda (procedure list) list))
    393     (filter! (lambda (procedure list) list))
    394     (partition! (lambda (procedure list) list))
    395     (remove! (lambda (procedure list) list))
    396     (find (lambda (procedure list) obj))
    397     (find-tail (lambda (procedure list) obj))
    398     (any (lambda ((lambda obj a) list \.\.\.) a))
    399     (every (lambda ((lambda obj a) list \.\.\.) a))
    400     (list-index (lambda (procedure list \.\.\.) (or bool integer)))
    401     (take-while (lambda (procedure list) list))
    402     (drop-while (lambda (procedure list) list))
    403     (take-while! (lambda (procedure list) list))
    404     (span (lambda (procedure list) list))
    405     (break (lambda (procedure list) list))
    406     (span! (lambda (procedure list) list))
    407     (break! (lambda (procedure list) list))
     397    (pair-fold-right (lambda ((lambda (obj1 obj2 . obj3) a) object list \.\.\.) a))
     398    (reduce-right (lambda ((lambda (obj1 obj2 . obj3) a) object list \.\.\.) a))
     399    (append-map (lambda ((lambda (obj1 . obj2)) list \.\.\.) list))
     400    (append-map! (lambda ((lambda (obj1 . obj2)) list \.\.\.) list))
     401    (map! (lambda ((lambda (obj1 . obj2)) list \.\.\.) list))
     402    (pair-for-each (lambda ((lambda (obj1 . obj2)) list \.\.\.) undefined))
     403    (filter-map (lambda ((lambda (obj1 . obj2)) list \.\.\.) list))
     404    (map-in-order (lambda ((lambda (obj1 . obj2)) list \.\.\.) list))
     405    (filter (lambda ((lambda (obj1 . obj2)) list) list))
     406    (partition (lambda ((lambda (obj) bool) list) list))
     407    (remove (lambda ((lambda (obj1) bool) list) list))
     408    (filter! (lambda ((lambda (obj1) bool) list) list))
     409    (partition! (lambda ((lambda (obj1) bool) list) list))
     410    (remove! (lambda ((lambda (obj1) bool) list) list))
     411    (find (lambda ((lambda (obj1) bool) list) obj))
     412    (find-tail (lambda ((lambda (obj1) bool) list) obj))
     413    (any (lambda ((lambda (obj1 . obj2) a) list \.\.\.) a))
     414    (every (lambda ((lambda (obj1 . obj2) a) list \.\.\.) a))
     415    (list-index (lambda ((lambda (obj1 . obj2)) list \.\.\.) (or bool integer)))
     416    (take-while (lambda ((lambda (obj)) list) list))
     417    (drop-while (lambda ((lambda (obj)) list) list))
     418    (take-while! (lambda ((lambda (obj)) list) list))
     419    (span (lambda ((lambda (obj)) list) list))
     420    (break (lambda ((lambda (obj)) list) list))
     421    (span! (lambda ((lambda (obj)) list) list))
     422    (break! (lambda ((lambda (obj)) list) list))
    408423    (delete (lambda (object list :optional procedure) list))
    409424    (delete-duplicates (lambda (list :optional procedure) list))
     
    12931308   ;; SRFI 69
    12941309   ("Basic hash tables"
     1310    (alist->hash-table (lambda (alist) hash-table))
     1311    (hash (lambda (obj :optional n) int))
     1312    (hash-by-identity (lambda (obj :optional n) int))
     1313    (hash-table->alist (lambda (hash-table) alist))
     1314    (hash-table-copy (lambda (hash-table) hash-table))
     1315    (hash-table-delete! (lambda (hash-table key) undefined))
     1316    (hash-table-equivalence-function (lambda (hash-table) pred))
     1317    (hash-table-exists? (lambda (hash-table key) bool))
     1318    (hash-table-fold (lambda (hash-table f init-value)))
     1319    (hash-table-hash-function (lambda (hash-table) f))
     1320    (hash-table-keys (lambda (hash-table) list))
     1321    (hash-table-merge! (lambda (hash-table1 hash-table2) undefined))
     1322    (hash-table-ref (lambda (hash-table key :optional thunk)))
     1323    (hash-table-ref/default (lambda (hash-table key default)))
     1324    (hash-table-remove! (lambda (hash-table proc) undefined))
     1325    (hash-table-set! (lambda (hash-table key value) undefined))
     1326    (hash-table-size (lambda (hash-table) n))
     1327    (hash-table-update! (lambda (hash-table key proc :optional thunk) undefined))
     1328    (hash-table-update!/default (lambda (hash-table key proc default) undefined))
     1329    (hash-table-values (lambda (hash-table) list))
     1330    (hash-table-walk (lambda (hash-table proc) undefined))
     1331    (hash-table? (lambda (obj) bool))
     1332    (make-hash-table (lambda (:optional eq-fn hash-fn) hash-table))
     1333    (string-ci-hash (lambda (str :optional n) n))
     1334    (string-hash (lambda (str1 :optional n) n))
    12951335    )
    12961336
     
    13931433     (read-lines (lambda (:optional port max) list))
    13941434     (read-string (lambda (:optional n port) str))
    1395      (read-string! (lambda (n dest :optional port start) undefined))
     1435     (read-string! (lambda (n dest :optional port start) n))
    13961436     (read-token (lambda (predicate :optional port) str))
    13971437     (shuffle (lambda (list) list))
    1398      (sort (lambda (sequence less-fn) sequence))
    1399      (sort! (lambda (sequence less-fn) sequence))
    1400      (sorted? (lambda (sequence less-fn) bool))
     1438     (sort (lambda ((or list vector) less-fn) (or list vector)))
     1439     (sort! (lambda ((or list vector) less-fn) (or list vector)))
     1440     (sorted? (lambda ((or list vector) less-fn) bool))
    14011441     (sprintf (lambda (format-string arg \.\.\.) str))
    14021442     (string-chomp (lambda (str :optional suffix-str) str))
     
    17661806     (chicken-version (lambda () string))
    17671807     (command-line-arguments (lambda () list))
     1808     (cond-expand (syntax))
    17681809     (condition-predicate (lambda (kind) pred))
    17691810     (condition-property-accessor (lambda (kind prop :optional err?) proc))
     
    18681909     (open-output-string (lambda () string-output-port))
    18691910     (ormap (lambda (pred list \.\.\.) bool))
    1870      (port-name (lambda (port) name))
    1871      (port-position (lambda (port) n))
     1911     (port-name (lambda (:optional port) name))
     1912     (port-position (lambda (:optional port) n))
    18721913     (port? (lambda (obj) bool))
    18731914     (print (lambda (obj \.\.\.) undefined))
     
    27232764                                   "/usr/local/lib/chicken"
    27242765                                   "/opt/lib/chicken"
    2725                                    "/opt/local/lib/chicken")))))
     2766                                   "/opt/local/lib/chicken"
     2767                                   )))))
    27262768        (and dir
    27272769             (car (reverse (sort (directory-files dir t "^[0-9]+$")
    27282770                                 #'string-lessp)))))
    27292771      (and (fboundp 'shell-command-to-string)
    2730            (let* ((res (shell-command-to-string "csi -p \"(repository-path)\""))
     2772           (let* ((res (shell-command-to-string
     2773                        "csi -e '(print (repository-path))'"))
    27312774                  (res (substring res 0 (- (length res) 1))))
    27322775             (and res (file-directory-p res) res)))
     
    27382781   (let ((home (getenv "CHICKEN_HOME")))
    27392782     (if (and home (not (equal home "")))
    2740          (let ((res (split-string home ";")))
    2741            (if (member *scheme-chicken-repo-dirs* res)
     2783         (let ((res (split-string home ";"))) ;
     2784           (if (member *scheme-chicken-base-repo* res)
    27422785               res
    27432786             (cons *scheme-chicken-repo-dirs* res)))
     
    28362879;; visit a file and kill the buffer only if it wasn't already open
    28372880(defmacro scheme-with-find-file (path-expr &rest body)
    2838   (let ((path (gensym))
    2839         (buf (gensym))
    2840         (res (gensym)))
     2881  (let ((path (gensym "path"))
     2882        (buf (gensym "buf"))
     2883        (res (gensym "res")))
    28412884    `(save-window-excursion
    28422885       (let* ((,path (file-truename ,path-expr))
    2843               (,buf (find-if #'(lambda (x) (equal ,path (buffer-file-name x)))
    2844                              (buffer-list))))
     2886              (,buf (find-if
     2887                     #'(lambda (x)
     2888                         (let ((buf-file (buffer-file-name x)))
     2889                           (and buf-file
     2890                                (equal ,path (file-truename buf-file)))))
     2891                     (buffer-list))))
    28452892         (if ,buf
    28462893             (switch-to-buffer ,buf)
    2847            (switch-to-buffer (find-file-noselect ,path t t)))
     2894           (switch-to-buffer (find-file-noselect ,path t)))
    28482895         (let ((,res (save-excursion ,@body)))
    28492896           (unless ,buf (kill-buffer (current-buffer)))
     
    29372984                       (beginning-of-defun)
    29382985                       (< here (point)))
    2939         (progn (forward-char) (re-search-forward "^(" nil t))
     2986        (progn (forward-char)
     2987               (and (re-search-forward "^(" nil t)
     2988                    (progn (backward-char 1) t)))
    29402989        (goto-char (point-max)))))
    29412990
     
    30923141;;   :group 'scheme-complete)
    30933142
     3143(defvar *scheme-interleave-definitions-p* nil)
     3144
    30943145(defvar *scheme-complete-module-cache* '())
    30953146
     
    31213172                   'guile
    31223173                 'gauche))
    3123               ((re-search-forward "(use " nil t)
     3174              ((re-search-forward "(\\(?:use\\|require-library\\) " nil t)
    31243175               'chicken)
    31253176              ((re-search-forward
    3126                 "\\(?:(module \\|#\\(?:lang\\|reader\\)\\)" nil t)
    3127                'mzscheme))))))
     3177                "#\\(?:lang\\|reader\\)" nil t)
     3178               'mzscheme)
     3179              ((re-search-forward "(module\\s-" nil t)
     3180               (if (looking-at "\\s-*\\sw") 'chicken 'mzscheme)))))))
    31283181  (or *scheme-current-implementation*
    31293182      scheme-default-implementation))
     
    32763329      (scheme-extract-import-module-imports (cadr sexp))))
    32773330    ((import import-for-syntax require)
    3278      (scheme-extract-import-module-imports (cadr sexp)))
     3331     (scheme-append-map #'scheme-extract-import-module-imports (cdr sexp)))
    32793332    ((library)
    32803333     (if (and (stringp (cadr sexp)) (file-exists-p (cadr sexp)))
     
    33013354     (scheme-append-map #'scheme-module-exports (cdr sexp)))
    33023355    ((import)
    3303      (scheme-extract-import-module-imports (cadr sexp)))
     3356     (scheme-append-map #'scheme-extract-import-module-imports (cdr sexp)))
    33043357    ((autoload)
    33053358     (unless (member (cadr sexp) *scheme-imported-modules*)
     
    33103363     (unless (member (cadr sexp) *scheme-imported-modules*)
    33113364       (push (cadr sexp) *scheme-imported-modules*)
    3312        (and (file-exists-p (cadr sexp))
     3365       (and (stringp (cadr sexp))
     3366            (file-exists-p (cadr sexp))
    33133367            (scheme-with-find-file (cadr sexp)
    33143368              (scheme-current-globals)))))
     
    33403394      ;; scan for module forms
    33413395      (while (not (eobp))
    3342         (if (ignore-errors (progn (forward-sexp) t))
    3343             (let ((end (point)))
     3396        (if (ignore-errors (forward-sexp) t)
     3397            (let ((end (point))
     3398                  (inside-p nil))
    33443399              (backward-sexp)
    33453400              (when (eq ?\( (char-after))
    33463401                (forward-char)
    3347                 (when (and (not (eq ?\( (char-after)))
    3348                            (scheme-module-symbol-p (scheme-symbol-at-point)))
    3349                   (backward-char)
    3350                   (ignore-errors
    3351                     (setq imports
    3352                           (append (scheme-extract-sexp-imports
    3353                                    (scheme-nth-sexp-at-point 0))
    3354                                   imports)))))
    3355               (goto-char end))
     3402                (when (not (eq ?\( (char-after)))
     3403                  (let ((sym (scheme-symbol-at-point)))
     3404                    (cond
     3405                     ((memq sym '(module library))
     3406                      (forward-sexp 3)
     3407                      (setq inside-p t))
     3408                     ((scheme-module-symbol-p sym)
     3409                      (backward-char)
     3410                      (ignore-errors
     3411                        (setq imports
     3412                              (append (scheme-extract-sexp-imports
     3413                                       (scheme-nth-sexp-at-point 0))
     3414                                      imports))))))))
     3415              (unless inside-p (goto-char end)))
    33563416          ;; if an incomplete sexp is found, try to recover at the
    33573417          ;; next line beginning with an open paren
     
    33753435      `(lambda ,(cdr (scheme-nth-sexp-at-point 0))))
    33763436     (t
    3377       (scheme-beginning-of-next-sexp)
    3378       (scheme-sexp-type-at-point)))))
     3437      (ignore-errors (scheme-beginning-of-next-sexp)
     3438                     (scheme-sexp-type-at-point))))))
    33793439
    33803440;; we should be at the opening paren of an expression
     
    34323492;; there's an error during normal sexp movement
    34333493(defun scheme-current-globals ()
    3434   (let ((globals '()))
     3494  (let ((here (point))
     3495        (globals '())
     3496        (end (point-max)))
    34353497    (save-excursion
    34363498      (goto-char (point-min))
    3437       (or (ignore-errors (end-of-defun) (beginning-of-defun) t)
    3438           (re-search-forward "^(" nil t)
     3499      (or (ignore-errors (end-of-defun) (backward-sexp) t)
     3500          (and (re-search-forward "^(" nil t) (progn (backward-char) t))
    34393501          (goto-char (point-max)))
    3440       (while (not (eobp))
    3441         (setq globals
    3442               (append (ignore-errors (scheme-extract-definitions)) globals))
    3443         (scheme-goto-next-top-level)))
     3502      (while (< (point) end)
     3503        (cond
     3504         ((and (< (point) here) (looking-at "(\\(module\\|library\\)\\s-"))
     3505          (let ((module-end (ignore-errors
     3506                              (save-excursion (forward-sexp) (point)))))
     3507            (cond
     3508             ((or (not module-end) (< here module-end)) ; inside the module
     3509              (setq globals '())
     3510              (when module-end
     3511                (setq end module-end))
     3512              (forward-word 1)
     3513              (forward-sexp 2)
     3514              (scheme-beginning-of-next-sexp))
     3515             (t ;; not inside the module, skip it altogether
     3516              (forward-sexp 1)
     3517              (scheme-goto-next-top-level)))))
     3518         (t
     3519          (setq globals
     3520                (append (ignore-errors (scheme-extract-definitions)) globals))
     3521          (or (and (progn (forward-char) (re-search-forward "^(" nil t))
     3522                   (progn (backward-char) t))
     3523              (scheme-goto-next-top-level))))))
    34443524    globals))
    34453525
     
    34583538                                (> (point) here))
    34593539                 (goto-char end)))
    3460            (t ;; non-definition form, stop scanning
     3540           ;; non-definition form, maybe stop scanning
     3541           ((not *scheme-interleave-definitions-p*)
    34613542            (goto-char end))))))
    34623543    defs))
     
    35433624                       (or (> (car mtime) (car ptime))
    35443625                           (and (= (car mtime) (car ptime))
    3545                                 (>= (cadr mtime) (cadr ptime)))))))
     3626                                (> (cadr mtime) (cadr ptime)))))))
    35463627          (setq *scheme-complete-module-cache*
    35473628                (assq-delete-all mod *scheme-complete-module-cache*))
     
    35693650    (if predefined
    35703651        (list nil (cdr predefined))
    3571       (let ((export-file
    3572              (concat *scheme-chicken-base-repo* "/"
    3573                      (symbol-name mod) ".exports"))
    3574             (setup-file
    3575              (concat *scheme-chicken-base-repo* "/"
    3576                      (symbol-name mod) ".setup-info"))
    3577             (source-file
    3578              (concat (symbol-name mod) ".scm")))
     3652      (let* ((mod-str (symbol-name mod))
     3653             (export-file
     3654              (concat *scheme-chicken-base-repo* "/" mod-str ".exports"))
     3655             (setup-file
     3656              (concat *scheme-chicken-base-repo* "/" mod-str ".setup-info"))
     3657             ;; look for the source in the current directory
     3658             (source-file (concat mod-str ".scm"))
     3659             ;; try the chicken 4 modules db
     3660             (modules-db (concat *scheme-chicken-base-repo* "/modules.db")))
    35793661        (cond
     3662         ((eq mod 'scheme)
     3663          (list nil *scheme-r5rs-info*))
    35803664         ((file-exists-p source-file)
    35813665          (list source-file
     
    35853669                    (if (consp exports)
    35863670                        (remove-if-not #'(lambda (x) (memq (car x) exports)) env)
    3587                         env)))))
     3671                      env)))))
    35883672         ((file-exists-p export-file)
    35893673          (list export-file
    35903674                (mapcar #'(lambda (x) (cons (intern x) '((lambda obj))))
    35913675                        (scheme-file->lines export-file))))
    3592          ((file-exists-p setup-file)
    3593           (list setup-file
    3594                 (mapcar #'(lambda (x) (cons (intern x) '((lambda obj))))
    3595                         (scheme-with-find-file setup-file
    3596                           (let* ((alist (scheme-nth-sexp-at-point 0))
    3597                                  (cell (assq 'exports alist)))
    3598                             (cdr cell))))))
     3676         (t
     3677          (let ((setup-file-exports
     3678                 (and (file-exists-p setup-file)
     3679                      (scheme-with-find-file setup-file
     3680                        (let* ((alist (scheme-nth-sexp-at-point 0))
     3681                               (cell (assq 'exports alist)))
     3682                          (cdr cell))))))
     3683            (cond
     3684             (setup-file-exports
     3685              (list setup-file
     3686                    (mapcar #'(lambda (x) (cons (intern x) '((lambda obj))))
     3687                            setup-file-exports)))
     3688             ((file-exists-p modules-db)
     3689              (list modules-db
     3690                    (mapcar
     3691                     #'(lambda (x)
     3692                         (cons (intern (car (split-string (substring x 1))))
     3693                               '((lambda ()))))
     3694                     (remove-if-not
     3695                      #'(lambda (x) (string-match (concat " " mod-str ")") x))
     3696                      (scheme-file->lines modules-db))))))))
    35993697         )))))
    36003698
     
    36383736
    36393737;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    3640 ;; This is rather complicated because we to auto-generate docstring
    3641 ;; summaries from the type information, which means inferring various
    3642 ;; types from common names.  The benefit is that you don't have to
    3643 ;; input the same information twice, and can often cut&paste&munge
    3644 ;; procedure descriptions from the original documentation.
     3738;; This is rather complicated because we want to auto-generate
     3739;; docstring summaries from the type information, which means
     3740;; inferring various types from common names.  The benefit is that you
     3741;; don't have to input the same information twice, and can often
     3742;; cut&paste&munge procedure descriptions from the original
     3743;; documentation.
    36453744
    36463745(defun scheme-translate-type (type)
     
    36703769        port input-port output-port pair list vector array stream hash-table
    36713770        thread mutex condition-variable time exception date duration locative
    3672         random-source state condition condition-type queue sequence pointer
     3771        random-source state condition condition-type queue pointer
    36733772        u8vector s8vector u16vector s16vector u32vector s32vector
    36743773        u64vector s64vector f32vector f64vector undefined symbol
     
    38143913    spec))
    38153914
     3915(defun scheme-inside-module-p ()
     3916  (save-excursion
     3917    (ignore-errors
     3918      (let ((here (point))
     3919            res)
     3920        (goto-char (point-min))
     3921        (while (< (point) here)
     3922          (if (not (re-search-forward "^(\\(?:module\\|library\\)\\s-"))
     3923              (goto-char (point-max))
     3924            (beginning-of-line)
     3925            (let ((mod-point (point)))
     3926              (if (ignore-errors (forward-sexp) t)
     3927                  (if (and (<= mod-point here) (<= here (point)))
     3928                      (setq res t))
     3929                (setq res (<= mod-point here))
     3930                (goto-char (point-max))))))
     3931        res))))
     3932
    38163933(defun scheme-current-env ()
    3817   ;; r5rs
    3818   (let ((env (list *scheme-r5rs-info*)))
    3819     ;; base language
    3820     (let ((base (cdr (assq (scheme-current-implementation)
    3821                            *scheme-implementation-exports*))))
    3822       (if base (push base env)))
    3823     ;; imports
    3824     (let ((imports (ignore-errors (scheme-current-imports))))
    3825       (if imports (push imports env)))
    3826     ;; top-level defs
    3827     (let ((top (ignore-errors (scheme-current-globals))))
    3828       (if top (push top env)))
    3829     ;; current local vars
    3830     (let ((locals (ignore-errors (scheme-current-local-vars env))))
    3831       (if locals (push locals env)))
    3832     env))
     3934  (let ((in-mod-p (scheme-inside-module-p)))
     3935    ;; r5rs
     3936    (let ((env (if in-mod-p (list) (list *scheme-r5rs-info*))))
     3937      ;; base language
     3938      (let ((base (cdr (assq (scheme-current-implementation)
     3939                             *scheme-implementation-exports*))))
     3940        (if (and base (not in-mod-p)) (push base env)))
     3941      ;; imports
     3942      (let ((imports (ignore-errors (scheme-current-imports))))
     3943        (if imports (push imports env)))
     3944      ;; top-level defs
     3945      (let ((top (ignore-errors (scheme-current-globals))))
     3946        (if top (push top env)))
     3947      ;; current local vars
     3948      (let ((locals (ignore-errors (scheme-current-local-vars env))))
     3949        (if locals (push locals env)))
     3950      env)))
    38333951
    38343952(defun scheme-env-filter (pred env)
     
    38723990                             (scheme-type-match-p a1 b2))))))
    38733991               (and (consp a1)
    3874                     ;; type unions
    3875                     (if (eq 'or (car a1))
    3876                         (find-if
    3877                          #'(lambda (x)
    3878                              (scheme-type-match-p (scheme-translate-type x) b1))
    3879                          (cdr a1))
    3880                       ;; other special types
    3881                       (let ((a2 (scheme-translate-special-type a1))
    3882                             (b2 (scheme-translate-special-type b1)))
    3883                         (and (or (not (equal a1 a2)) (not (equal b1 b2)))
    3884                              (scheme-type-match-p a2 b2))))
    3885                     ))))))
     3992                    (case (car a1)
     3993                      ((or)
     3994                       ;; type unions
     3995                       (find-if
     3996                        #'(lambda (x)
     3997                            (scheme-type-match-p (scheme-translate-type x) b1))
     3998                        (cdr a1)))
     3999                      ((lambda)
     4000                       ;; procedures
     4001                       (or (eq 'procedure b1)
     4002                           (and (consp b1)
     4003                                (eq 'lambda (car b1))
     4004                                (scheme-param-list-match-p (cadr a1)
     4005                                                           (cadr b1)))))
     4006                      (t
     4007                       ;; other special types
     4008                       (let ((a2 (scheme-translate-special-type a1))
     4009                             (b2 (scheme-translate-special-type b1)))
     4010                         (and (or (not (equal a1 a2)) (not (equal b1 b2)))
     4011                              (scheme-type-match-p a2 b2)))))))))))
     4012
     4013(defun scheme-param-list-match-p (p1 p2)
     4014  (or (and (symbolp p1) (not (null p1)))
     4015      (and (symbolp p2) (not (null p2)))
     4016      (and (null p1) (null p2))
     4017      (and (consp p1) (consp p2)
     4018           (scheme-param-list-match-p (cdr p1) (cdr p2)))))
    38864019
    38874020(defun scheme-translate-special-type (x)
Note: See TracChangeset for help on using the changeset viewer.