changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/lib/skel/comp/asd.lisp

changeset 468: 121a0253aa3c
parent: c40d2a41d7ce
child: 7354623e5b54
author: Richard Westhaver <ellis@rwest.io>
date: Sat, 22 Jun 2024 00:51:41 -0400
permissions: -rw-r--r--
description: progress on asd comp 
     1 ;;; lib/skel/comp/asd.lisp --- ASDF System Definition Compiler
     2 
     3 ;; ASDF/PARSE-DEFSYSTEM may come in handy for testing.
     4 
     5 ;; The problem with ASD files is that they're read-only afaik - eg there's no
     6 ;; 'write' methods implemented on ASD:SYSTEM objects. This makes it a bit
     7 ;; tedious because we obviously want to transform SK-LISP-SYSTEM objects
     8 ;; directly to SYSTEM, but also need to be able to write them out as discrete
     9 ;; files for portability. Probably will end up violating all that is DRY and
    10 ;; holy.
    11 
    12 ;;; Code:
    13 (in-package :skel/comp/asd)
    14 
    15 (defclass sk-lisp-system (skel asdf:system) ())
    16 
    17 (defun read-system-definitions (system)
    18   (with-open-file (file (asdf:system-source-file system))
    19     (loop for x = (read file nil)
    20           while x
    21           collect x)))
    22 
    23 (defun to-sk-system (system)
    24   (let ((sys (change-class system 'sk-lisp-system)))
    25     (id:update-id sys)
    26     sys))
    27 
    28 (defun find-sk-system (system)
    29   (to-sk-system (asdf:find-system system)))
    30 
    31 (defun parse-sk-system (name path &optional opts)
    32   (to-sk-system (asdf::parse-component-form nil (list* :system name :pathname path opts))))
    33 
    34 (defmethod sk-load ((self sk-lisp-system) &key force force-not verbose version)
    35   (asdf:load-system self :force force :force-not force-not :verbose verbose :version version))
    36 
    37 (defmethod sk-compile ((self sk-lisp-system) stream &key &allow-other-keys))
    38 
    39 (defun sk-write-asd-components (module)
    40   (etypecase module
    41     (asdf:file-component
    42      (list (keywordicate (string-upcase (asdf:file-type module)))
    43            (pathname-name (asdf:component-relative-pathname module))))
    44     (asdf:module
    45      (list :module
    46            (asdf:component-name module)
    47            `(,@(when-let ((%c (asdf:module-components module)))
    48                  `((:components ,(mapcar #'sk-write-asd-components %c)))))))))
    49 
    50 (defmethod sk-write-file ((self sk-lisp-system) &key path)
    51   (let ((name (asdf:component-name self)))
    52   (with-open-file (s path
    53                      :direction :output
    54                      :if-does-not-exist :create)
    55     (format s ";;; ASDF definition for system ~A~%" name)
    56             
    57     (format s ";;; Built for ~A ~A on a ~A/~A ~A~%"
    58             (lisp-implementation-type)
    59             (lisp-implementation-version)
    60             (software-type)
    61             (machine-type)
    62             (software-version))
    63     (let ((*package* (find-package :asdf-user))
    64           (*print-case* :downcase))
    65       (pprint `(defsystem ,name
    66                  :class prebuilt-system
    67                  :version ,(asdf:component-version self)
    68                  :depends-on ,(asdf:system-depends-on self)
    69                  :components ,(mapcar #'sk-write-asd-components
    70                                       (cdr (asdf:module-components self))))
    71               s)
    72       (terpri s)))))
    73 
    74 ;; (sk-write-file (find-sk-system :skel) :path "test")
    75 
    76 (defmethod sk-read-file ((self sk-lisp-system) path)
    77   (parse-sk-system (pathname-name path) (pathname-directory path)))