code.consxy.com Git - clnl/blob - src/main/extensions.lisp

   1 (in-package #:clnl-extensions)
   2
   3 (defgeneric prims (extension)
   4  (:documentation
   5   "PRIMS EXTENSION => PRIMS
   6
   7   PRIMS: PRIM*
   8   PRIM: (:name NAME :type TYPE :args ARGS :func FUNC)
   9   TYPE: :command | :reporter
  10   ARGS: ARG*
  11
  12 ARGUMENTS AND VALUES:
  13
  14   EXTENSION: a symbol in the keyword package representing this extension
  15   NAME: a symbol in the keyword package
  16   FUNC: the function to call
  17   ARG: a list of symbols denoting the type of argument
  18
  19 DESCRIPTION:
  20
  21   PRIMS returns the primitives used in the extension passed in.
  22
  23   See CLNL-PARSER:PARSE for more information on the PRIM returned."))
  24
  25 (defun load-extension (extension)
  26  "LOAD-EXTENSION EXTENSION => PRIMS
  27
  28 ARGUMENTS AND VALUES:
  29
  30   EXTENSION: A symbol
  31   PRIMS: Primitives that can be sent to the parser and transpiler
  32
  33 DESCRIPTION:
  34
  35   LOAD-EXTENSION takes an EXTENSION and does the work to load the asdf package,
  36   as well as munge the prims from extension style prims to things to be used by
  37   the CLNL compiler stack.
  38
  39   It returns those PRIMS after checking that all the pieces are there to not
  40   break the runtime."
  41  (let*
  42   ((name (intern (format nil "CLNL-EXTENSION-~A" (string-upcase extension)) :keyword)))
  43   (asdf:load-system name)
  44   (let
  45    ((pkg (find-package name)))
  46    (when (or (not pkg)) (error "Can't find package with extension name: ~A" name))
  47    (when (not (compute-applicable-methods #'prims (list extension)))
  48     (error "Can't find implemented PRIMS method within extension: ~A" name))
  49    (mapcar
  50     (lambda (prim)
  51      (when (not (getf prim :name)) (error "Prim requires a name: ~A ~A" name prim))
  52      (let
  53       ((type (getf prim :type)))
  54       (when (or (not type) (not (find type '(:reporter :command))))
  55        (error "Prim type invalid, needs to be :reporter or :command: ~A ~A ~A" name prim type)))
  56      (when (not (getf prim :func))
  57       (error "Prim needs a func: ~A ~A" name prim))
  58      (list
  59       :name (intern
  60              (format nil "~A:~A"
  61               (if (eql extension :cli) "" (string-upcase extension))
  62               (string-upcase (getf prim :name)))
  63              :keyword)
  64       :type (getf prim :type)
  65       :precedence (or (getf prim :precedence) (if (eql :reporter (getf prim :type)) 10 0))
  66       :args (getf prim :args)
  67       :func (getf prim :func)))
  68     (prims extension)))))