Add ensure-symbol

s-expressionists · Nov 2, 2023 · 1d4439f · 1d4439f
1 parent 290932f
commit 1d4439f
Showing 1 changed file with 53 additions and 49 deletions.
diff --git a/code/interface.lisp b/code/interface.lisp
@@ -1,6 +1,7 @@
 (in-package #:inravina)
 
-(declaim (inline coerce-output-stream-designator))
+(declaim (inline coerce-output-stream-designator
+                 ensure-symbol))
 
 (defun coerce-output-stream-designator (designator)
   (cond ((null designator)
@@ -16,6 +17,9 @@
                 :format-control "~S isn't an output stream."
                 :format-arguments (list designator)))))
 
+(defun ensure-symbol (name &optional (package *package*))
+  (intern (string name) package))
+
 (defvar *quasiquote* nil)
 
 (defvar *options*
@@ -188,13 +192,13 @@
               (funcall ,body-fun))))))
 
 (defmacro define-interface ((client-var client-class &optional intrinsic) &body body)
-  (let* ((intrinsic-pkg (if intrinsic (find-package "COMMON-LISP") *package*))
-         (initial-pprint-dispatch-var (intern "*INITIAL-PPRINT-DISPATCH*"))
-         (standard-pprint-dispatch-var (intern "*STANDARD-PPRINT-DISPATCH*"))
-         (print-pprint-dispatch-var (intern "*PRINT-PPRINT-DISPATCH*" intrinsic-pkg))
-         (pprint-pop-func (intern "PPRINT-POP" intrinsic-pkg))
-         (pprint-exit-if-list-exhausted-func (intern "PPRINT-EXIT-IF-LIST-EXHAUSTED" intrinsic-pkg))
-         (initialize-func (intern "INITIALIZE")))
+  (let* ((intrinsic-pkg (if intrinsic (find-package '#:common-lisp) *package*))
+         (initial-pprint-dispatch-var (ensure-symbol '#:*initial-pprint-dispatch*))
+         (standard-pprint-dispatch-var (ensure-symbol '#:*standard-pprint-dispatch*))
+         (print-pprint-dispatch-var (ensure-symbol '#:*print-pprint-dispatch* intrinsic-pkg))
+         (pprint-pop-func (ensure-symbol '#:pprint-pop intrinsic-pkg))
+         (pprint-exit-if-list-exhausted-func (ensure-symbol '#:pprint-exit-if-list-exhausted intrinsic-pkg))
+         (initialize-func (ensure-symbol '#:initialize)))
     `(progn
        (defmethod make-dispatch-function
            ((client ,client-class) (pattern (eql :client-stream-object)) function rest)
@@ -215,141 +219,141 @@
        (defvar ,initial-pprint-dispatch-var nil)
        (defvar ,standard-pprint-dispatch-var nil)
        (defvar ,print-pprint-dispatch-var)
-       (defun ,(intern "PRETTY-STREAM-P") (stream)
+       (defun ,(ensure-symbol '#:pretty-stream-p) (stream)
          (pretty-stream-p ,client-var stream))
-       (defun ,(intern "COPY-PPRINT-DISPATCH" intrinsic-pkg) (&optional (table ,print-pprint-dispatch-var))
+       (defun ,(ensure-symbol '#:copy-pprint-dispatch intrinsic-pkg) (&optional (table ,print-pprint-dispatch-var))
          #+ecl ,@(when intrinsic '((declare (ext:check-arguments-type nil))))
          (check-type table (or null dispatch-table))
          (copy-pprint-dispatch ,client-var (or table ,initial-pprint-dispatch-var)))
-       (defun ,(intern "SET-PPRINT-DISPATCH" intrinsic-pkg)
+       (defun ,(ensure-symbol '#:set-pprint-dispatch intrinsic-pkg)
            (type-specifier function &optional (priority 0) (table ,print-pprint-dispatch-var))
          #+ecl ,@(when intrinsic '((declare (ext:check-arguments-type nil))))
          (check-type priority real)
          (check-type table dispatch-table)
          (check-type function (or symbol function))
          (set-pprint-dispatch ,client-var table type-specifier function priority))
-       (defun ,(intern "PPRINT-FILL" intrinsic-pkg) (stream object &optional (colon-p t) at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-fill intrinsic-pkg) (stream object &optional (colon-p t) at-sign-p)
          (pprint-fill ,client-var (coerce-output-stream-designator stream)
                       object colon-p at-sign-p)
          nil)
-       (defun ,(intern "PPRINT-LINEAR" intrinsic-pkg) (stream object &optional (colon-p t) at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-linear intrinsic-pkg) (stream object &optional (colon-p t) at-sign-p)
          (pprint-linear ,client-var (coerce-output-stream-designator stream)
                         object colon-p at-sign-p)
          nil)
-       (defun ,(intern "PPRINT-TABULAR" intrinsic-pkg) (stream object &optional (colon-p t) at-sign-p (tabsize 16))
+       (defun ,(ensure-symbol '#:pprint-tabular intrinsic-pkg) (stream object &optional (colon-p t) at-sign-p (tabsize 16))
          (pprint-tabular ,client-var (coerce-output-stream-designator stream)
                          object colon-p at-sign-p tabsize)
          nil)
-       (defun ,(intern "PPRINT-INDENT" intrinsic-pkg) (relative-to n &optional stream)
+       (defun ,(ensure-symbol '#:pprint-indent intrinsic-pkg) (relative-to n &optional stream)
          (check-type relative-to (member :block :current))
          (pprint-indent ,client-var (coerce-output-stream-designator stream)
                         relative-to n)
          nil)
-       (defun ,(intern "PPRINT-NEWLINE" intrinsic-pkg) (kind &optional stream)
+       (defun ,(ensure-symbol '#:pprint-newline intrinsic-pkg) (kind &optional stream)
          (check-type kind (member :linear :fill :miser :mandatory))
          (pprint-newline ,client-var (coerce-output-stream-designator stream)
                          kind)
          nil)
-       (defun ,(intern "PPRINT-TAB" intrinsic-pkg) (kind colnum colinc &optional stream)
+       (defun ,(ensure-symbol '#:pprint-tab intrinsic-pkg) (kind colnum colinc &optional stream)
          (check-type kind (member :line :section :line-relative :section-relative))
          (pprint-tab ,client-var (coerce-output-stream-designator stream)
                      kind colnum colinc)
          nil)
-       (defun ,(intern "PPRINT-ARRAY") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-array) (stream object &optional colon-p at-sign-p)
          (pprint-array ,client-var (coerce-output-stream-designator stream)
                        object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-APPLY") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-apply) (stream object &optional colon-p at-sign-p)
          (pprint-apply ,client-var (coerce-output-stream-designator stream)
                        object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-BINDINGS") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-bindings) (stream object &optional colon-p at-sign-p)
          (pprint-bindings ,client-var (coerce-output-stream-designator stream)
                           object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-CALL") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-call) (stream object &optional colon-p at-sign-p)
          (pprint-call ,client-var (coerce-output-stream-designator stream)
                       object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-CASE") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-case) (stream object &optional colon-p at-sign-p)
          (pprint-case ,client-var (coerce-output-stream-designator stream)
                       object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-COND") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-cond) (stream object &optional colon-p at-sign-p)
          (pprint-cond ,client-var (coerce-output-stream-designator stream)
                       object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-DEFCLASS") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-defclass) (stream object &optional colon-p at-sign-p)
          (pprint-defclass ,client-var (coerce-output-stream-designator stream)
                           object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-DEFUN") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-defun) (stream object &optional colon-p at-sign-p)
          (pprint-defun ,client-var (coerce-output-stream-designator stream)
                        object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-DEFMETHOD") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-defmethod) (stream object &optional colon-p at-sign-p)
          (pprint-defmethod ,client-var (coerce-output-stream-designator stream)
                            object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-DEFPACKAGE") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-defpackage) (stream object &optional colon-p at-sign-p)
          (pprint-defpackage ,client-var (coerce-output-stream-designator stream)
                             object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-DO") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-do) (stream object &optional colon-p at-sign-p)
          (pprint-do ,client-var (coerce-output-stream-designator stream)
                     object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-DOLIST") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-dolist) (stream object &optional colon-p at-sign-p)
          (pprint-dolist ,client-var (coerce-output-stream-designator stream)
                         object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-FLET") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-flet) (stream object &optional colon-p at-sign-p)
          (pprint-flet ,client-var (coerce-output-stream-designator stream)
                       object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-LAMBDA") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-lambda) (stream object &optional colon-p at-sign-p)
          (pprint-lambda ,client-var (coerce-output-stream-designator stream)
                         object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-LET") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-let) (stream object &optional colon-p at-sign-p)
          (pprint-let ,client-var (coerce-output-stream-designator stream)
                      object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-LOOP") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-loop) (stream object &optional colon-p at-sign-p)
          (pprint-loop ,client-var (coerce-output-stream-designator stream)
                       object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-MULTIPLE-VALUE-BIND") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-multiple-value-bind) (stream object &optional colon-p at-sign-p)
          (pprint-multiple-value-bind ,client-var (coerce-output-stream-designator stream)
                                      object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-PROG") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-prog) (stream object &optional colon-p at-sign-p)
          (pprint-prog ,client-var (coerce-output-stream-designator stream)
                       object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-PROG1") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-prog1) (stream object &optional colon-p at-sign-p)
          (pprint-prog1 ,client-var (coerce-output-stream-designator stream)
                        object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-PROG2") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-prog2) (stream object &optional colon-p at-sign-p)
          (pprint-prog2 ,client-var (coerce-output-stream-designator stream)
                        object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-PROGN") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-progn) (stream object &optional colon-p at-sign-p)
          (pprint-progn ,client-var (coerce-output-stream-designator stream)
                        object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-PROGV") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-progv) (stream object &optional colon-p at-sign-p)
          (pprint-progv ,client-var (coerce-output-stream-designator stream)
                        object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-SYMBOL-MACROLET") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-symbol-macrolet) (stream object &optional colon-p at-sign-p)
          (pprint-symbol-macrolet ,client-var (coerce-output-stream-designator stream)
                                  object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-TAGBODY") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-tagbody) (stream object &optional colon-p at-sign-p)
          (pprint-tagbody ,client-var (coerce-output-stream-designator stream)
                          object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-FUNCTION-CALL") (stream object &optional colon-p at-sign-p argument-count)
+       (defun ,(ensure-symbol '#:pprint-function-call) (stream object &optional colon-p at-sign-p argument-count)
          (pprint-function-call ,client-var (coerce-output-stream-designator stream)
                                object colon-p at-sign-p argument-count))
-       (defun ,(intern "PPRINT-ARGUMENT-LIST") (stream object &optional colon-p at-sign-p argument-count)
+       (defun ,(ensure-symbol '#:pprint-argument-list) (stream object &optional colon-p at-sign-p argument-count)
          (pprint-argument-list ,client-var (coerce-output-stream-designator stream)
                                object colon-p at-sign-p argument-count))
-       (defun ,(intern "PPRINT-WITH") (stream object &optional colon-p at-sign-p argument-count)
+       (defun ,(ensure-symbol '#:pprint-with) (stream object &optional colon-p at-sign-p argument-count)
          (pprint-with ,client-var (coerce-output-stream-designator stream)
                       object colon-p at-sign-p argument-count))
-       (defun ,(intern "PPRINT-LAMBDA-LIST") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-lambda-list) (stream object &optional colon-p at-sign-p)
          (pprint-lambda-list ,client-var (coerce-output-stream-designator stream)
                              object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-DESTRUCTURING-BIND") (stream object &optional colon-p at-sign-p)
+       (defun ,(ensure-symbol '#:pprint-destructuring-bind) (stream object &optional colon-p at-sign-p)
          (pprint-destructuring-bind ,client-var (coerce-output-stream-designator stream)
                                     object colon-p at-sign-p))
-       (defun ,(intern "PPRINT-MACRO-CHAR") (stream object &optional colon-p at-sign-p disp-char sub-char)
+       (defun ,(ensure-symbol '#:pprint-macro-char) (stream object &optional colon-p at-sign-p disp-char sub-char)
          (pprint-macro-char ,client-var (coerce-output-stream-designator stream)
                             object colon-p at-sign-p disp-char sub-char))
-       (defun ,(intern "PPRINT-DISPATCH" intrinsic-pkg) (object &optional (table ,print-pprint-dispatch-var))
+       (defun ,(ensure-symbol '#:pprint-dispatch intrinsic-pkg) (object &optional (table ,print-pprint-dispatch-var))
          #+ecl ,@(when intrinsic '((declare (ext:check-arguments-type nil))))
          (check-type table (or null dispatch-table))
          (pprint-dispatch ,client-var (or table ,initial-pprint-dispatch-var) object))
-       (defmacro ,(intern "PPRINT-LOGICAL-BLOCK" intrinsic-pkg) ((stream-symbol object
+       (defmacro ,(ensure-symbol '#:pprint-logical-block intrinsic-pkg) ((stream-symbol object
                                                                   &key (prefix "" prefix-p)
                                                                        (per-line-prefix "" per-line-prefix-p)
                                                                        (suffix "" suffix-p))