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

   1 (in-package #:clnl-extensions)
   2
   3 (defun load-extension (extension)
   4  "LOAD-EXTENSION EXTENSION => PRIMS
   5
   6 ARGUMENTS AND VALUES:
   7
   8   EXTENSION: A symbol
   9   PRIMS: Primitives that can be sent to the parser and transpiler
  10
  11 DESCRIPTION:
  12
  13   LOAD-EXTENSION takes an EXTENSION and does the work to load the asdf package,
  14   as well as munge the prims from extension style prims to things to be used by
  15   the CLNL compiler stack.
  16
  17   It returns those PRIMS after checking that all the pieces are there to not
  18   break the runtime."
  19  (let*
  20   ((name (intern (format nil "CLNL-EXTENSION-~A" (string-upcase extension)) :keyword)))
  21   (asdf:load-system name)
  22   (let
  23    ((pkg (find-package name)))
  24    (when (or (not pkg)) (error "Can't find package with extension name: ~A" name))
  25    (multiple-value-bind (symb status) (find-symbol "PRIMS" pkg)
  26     (when (not symb) (error "Can't find PRIMS function within extension: ~A" name))
  27     (when (not (eql status :external)) (error "PRIMS function is not external in extension: ~A" name))
  28     (when (not (and (fboundp symb) (not (macro-function symb)) (not (special-operator-p symb))))
  29      (error "PRIMS is not a function in ~A" name))
  30     (mapcar
  31      (lambda (prim)
  32       (when (not (getf prim :name)) (error "Prim requires a name: ~A ~A" name prim))
  33       (let
  34        ((type (getf prim :type)))
  35        (when (or (not type) (not (find type '(:reporter :command))))
  36         (error "Prim type invalid, needs to be :reporter or :command: ~A ~A ~A" name prim type)))
  37       (when (not (getf prim :func))
  38        (error "Prim needs a func: ~A ~A" name prim))
  39       (list
  40        :name (intern
  41               (format nil "~A:~A"
  42                (if (eql extension :cli) "" (string-upcase extension))
  43                (string-upcase (getf prim :name)))
  44               :keyword)
  45        :type (getf prim :type)
  46        :precedence (or (getf prim :precedence) (if (eql :reporter (getf prim :type)) 10 0))
  47        :args (getf prim :args)
  48        :func (getf prim :func)))
  49      (funcall (symbol-function symb)))))))