From 4bac829a58471a9921da44c2e7190ad7e5375b08 Mon Sep 17 00:00:00 2001 From: Tianyu Gu Date: Sat, 29 Jul 2023 18:20:25 +1000 Subject: [PATCH] Fix compatibility for AllegroCL especially for Allegro's Modern Mode: https://franz.com/support/tech_corner/modern.mode.lhtml --- slynk/slynk-backend.lisp | 6 ++++-- slynk/slynk-completion.lisp | 12 ++++++++---- slynk/slynk.lisp | 38 ++++++++++++++++++++++++++++++------- 3 files changed, 43 insertions(+), 13 deletions(-) diff --git a/slynk/slynk-backend.lisp b/slynk/slynk-backend.lisp index 9c0f06fa3..9977dc1b5 100644 --- a/slynk/slynk-backend.lisp +++ b/slynk/slynk-backend.lisp @@ -1487,9 +1487,11 @@ Return :interrupt if an interrupt occurs while waiting." (error "~s not implemented. Check if ~s = ~s is supported by the implementation." 'wait-for-input - (slynk-backend:find-symbol2 "SLYNK:*COMMUNICATION-STYLE*") + (slynk-backend:find-symbol2 #1=#.(if (eq :UPCASE (readtable-case *readtable*)) + "SLYNK:*COMMUNICATION-STYLE*" + "slynk:*communication-style*")) (symbol-value - (slynk-backend:find-symbol2 "SLYNK:*COMMUNICATION-STYLE*")))))) + (slynk-backend:find-symbol2 #1#)))))) ;;;; Locks diff --git a/slynk/slynk-completion.lisp b/slynk/slynk-completion.lisp index dd5c489a4..407bc820c 100644 --- a/slynk/slynk-completion.lisp +++ b/slynk/slynk-completion.lisp @@ -402,7 +402,9 @@ Returns a list of (COMPLETIONS NIL). COMPLETIONS is a list of (when (plusp (length pattern)) (list (loop with package = (guess-buffer-package package-name) - with upcasepat = (string-upcase pattern) + with upcasepat = (if (eq :UPCASE (readtable-case *readtable*)) + (string-upcase pattern) + pattern) for (string symbol indexes score) in (loop with (external internal) @@ -417,9 +419,11 @@ Returns a list of (COMPLETIONS NIL). COMPLETIONS is a list of for i upto limit collect e) collect - (list (if (every #'common-lisp:upper-case-p pattern) - (string-upcase string) - (string-downcase string)) + (list (case (readtable-case *readtable*) + (:UPCASE (string-upcase string)) + (:downcase (string-downcase string)) + (t string) ; FIXME: what about :invert mode? + ) score (to-chunks string indexes) (readably-classify symbol))) diff --git a/slynk/slynk.lisp b/slynk/slynk.lisp index 705404597..3e4115d1c 100644 --- a/slynk/slynk.lisp +++ b/slynk/slynk.lisp @@ -902,7 +902,12 @@ keywords: :BOUNDP, :FBOUNDP, :CONSTANT, :GENERIC-FUNCTION, (when (find-class symbol nil) (push :class result)) (when (macro-function symbol) (push :macro result)) (when (special-operator-p symbol) (push :special-operator result)) - (when (find-package symbol) (push :package result)) + (when #-allegro (find-package symbol) + #+allegro (handler-case (find-package symbol) + (error (e) + (log-event "classify-symbol: error raised in find-package (allegro)") + nil)) + (push :package result)) (when (and (fboundp symbol) (typep (ignore-errors (fdefinition symbol)) 'generic-function)) @@ -1625,7 +1630,10 @@ converted to lower case." (process-form-for-emacs (cdr form)))) (character (format nil "?~C" form)) (symbol (concatenate 'string (when (eq (symbol-package form) - #.(find-package "KEYWORD")) + #.(find-package + (if (eq :UPCASE (readtable-case *readtable*)) + "KEYWORD" + "keyword"))) ":") (string-downcase (symbol-name form)))) (number (let ((*print-base* 10)) @@ -2966,11 +2974,19 @@ soon once non-ASDF loading is removed. (see github#134)") Receives a module name as argument and should return non-nil if it managed to load it.") (:method ((method (eql :slynk-loader)) module) - (funcall (intern "REQUIRE-MODULE" :slynk-loader) module)) + (funcall (intern #.(if (eq :UPCASE (readtable-case *readtable*)) + "REQUIRE-MODULE" + "require-module") + :slynk-loader) + module)) (:method ((method (eql :asdf)) module) (unless *asdf-load-in-progress* (let ((*asdf-load-in-progress* t)) - (funcall (intern "LOAD-SYSTEM" :asdf) module))))) + (funcall (intern #.(if (eq :UPCASE (readtable-case *readtable*)) + "LOAD-SYSTEM" + "load-system") + :asdf) + module))))) (defun add-to-load-path-1 (path load-path-var) (pushnew path (symbol-value load-path-var) :test #'equal)) @@ -2979,9 +2995,15 @@ managed to load it.") (:documentation "Using METHOD, consider PATH when searching for modules.") (:method ((method (eql :slynk-loader)) path) - (add-to-load-path-1 path (intern "*LOAD-PATH*" :slynk-loader))) + (add-to-load-path-1 path (intern #.(if (eq :UPCASE (readtable-case *readtable*)) + "*LOAD-PATH*" + "*load-path*") + :slynk-loader))) (:method ((method (eql :asdf)) path) - (add-to-load-path-1 path (intern "*CENTRAL-REGISTRY*" :asdf)))) + (add-to-load-path-1 path (intern #.(if (eq :UPCASE (readtable-case *readtable*)) + "*CENTRAL-REGISTRY*" + "*central-registry*") + :asdf)))) (defvar *slynk-require-hook* '() "Functions run after SLYNK-REQUIRE. Called with new modules.") @@ -3219,7 +3241,9 @@ QUALIFIERS and SPECIALIZERS are lists of strings." (mapcar (lambda (specializer) (if (typep specializer 'slynk-mop:eql-specializer) (format nil "(eql ~A)" - (slynk-mop:eql-specializer-object specializer)) + (funcall #+allegro 'mop:eql-specializer-object + #+sbcl 'sb-mop:eql-specializer-object + specializer)) (prin1-to-string (class-name specializer)))) (slynk-mop:method-specializers method)))) (slynk-mop:generic-function-methods (read-as-function generic-name))))