path: root/stdlib/struct.tl

;; Copyright 2015-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
;; 1. Redistributions of source code must retain the above copyright notice,
;;    this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;;    this list of conditions and the following disclaimer in the documentation
;;    and/or other materials provided with the distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;; POSSIBILITY OF SUCH DAMAGE.

(defvar *struct-clause-expander* (hash))

(defvar *struct-prelude* (hash))
(defvar *struct-prelude-alists* (hash))

(defun sys:bad-slot-syntax (form arg)
  (compile-error form "bad slot syntax ~s" arg))

(defun sys:prune-missing-inits (slot-init-forms)
  (remove-if (tb ((kind name : (init-form nil init-form-present)))
               (ignore name init-form)
               (and (member kind '(:static :instance :function))
                    (not init-form-present)))
             slot-init-forms))

(defmacro sys:meth-lambda (struct slot params . body)
  ^(symacrolet ((%fun% '(,struct ,slot)))
     (lambda ,params ,*body)))

(defmacro defstruct (:form form name-spec super-spec . slot-specs)
  (tree-bind (name args) (tree-case name-spec
                           ((atom . args) (list atom args))
                           (atom (list atom nil)))
    (unless (bindable name)
      (compile-error form "~s isn't a bindable symbol" name))
    (if (built-in-type-p name)
      (compile-warning form "~s is a built-in type" name))
    (unless (proper-listp slot-specs)
      (compile-error form "bad syntax: dotted form"))
    (set slot-specs (append [*struct-prelude* name] slot-specs))
    (let ((instance-init-forms nil)
          (instance-postinit-forms nil)
          (instance-fini-forms nil)
          (instance-postfini-forms nil)
          (additional-supers nil))
      (labels ((expand-slot (form slot)
                 (tree-case slot
                   ((op . t)
                    (iflet ((expander [*struct-clause-expander* op]))
                      (append-each ((exslot [expander slot form]))
                        [expand-slot form exslot])
                      :))
                   ((word . args)
                    (cond
                      ((eq word :inherit)
                       (set additional-supers (revappend args additional-supers))
                       nil)
                      (t :)))
                   ((word slname args . body)
                    (caseq word
                      (:method
                        (when (not args)
                          (compile-error form "method ~s needs at least one parameter" slname))
                        ^((:function ,slname
                            (sys:meth-lambda ,slname ,name ,args
                              (block ,slname ,*body)))))
                      (:function ^((,word ,slname
                                          (sys:meth-lambda ,slname ,name ,args
                                            (block ,slname
                                              ,*body)))))
                      ((:static :instance)
                       (when body
                         (sys:bad-slot-syntax form slot))
                       ^((,word ,slname ,args)))
                      (t :)))
                   ((word (arg) . body)
                    (caseq word
                      (:init
                        (unless (bindable arg)
                          (sys:bad-slot-syntax form slot))
                        (if body
                          (push (cons arg body) instance-init-forms))
                        ^((,word nil nil)))
                      (:postinit
                        (unless (bindable arg)
                          (sys:bad-slot-syntax form slot))
                        (if body
                          (push (cons arg body) instance-postinit-forms))
                        ^((,word nil nil)))
                      (:fini
                        (unless (bindable arg)
                          (sys:bad-slot-syntax form slot))
                        (if body
                          (push (cons arg body) instance-fini-forms))
                        ^((,word nil nil)))
                      (:postfini
                        (unless (bindable arg)
                          (sys:bad-slot-syntax form slot))
                        (if body
                          (push (cons arg body) instance-postfini-forms))
                        ^((,word nil nil)))
                      (t (when body
                           (sys:bad-slot-syntax form slot))
                         :)))
                   ((word name)
                    (caseq word
                      ((:static)
                       ^((,word ,name)))
                      ((:instance)
                       ^((,word ,name nil)))
                      ((:method :function)
                       (sys:bad-slot-syntax form slot))
                      (t ^((:instance ,word ,name)))))
                   ((name)
                    ^((:instance ,name nil)))
                   (name
                     ^((:instance ,name nil))))))
        (let* ((slot-init-forms (append-each ((slot slot-specs))
                                  (expand-slot form slot)))
               (supers (append (if (and super-spec (atom super-spec))
                                 (list super-spec)
                                 super-spec)
                               additional-supers))
               (stat-si-forms [keep-if (op member @1 '(:static :function))
                                       slot-init-forms car])
               (pruned-si-forms (sys:prune-missing-inits stat-si-forms))
               (func-si-forms [keep-if (op eq :function) pruned-si-forms car])
               (val-si-forms [keep-if (op eq :static) pruned-si-forms car])
               (inst-si-forms [keep-if (op eq :instance) slot-init-forms car])
               (stat-slots [mapcar second stat-si-forms])
               (inst-slots [mapcar second inst-si-forms]))
          (whenlet ((bad [find-if [notf bindable]
                                  (append stat-slots inst-slots)]))
            (compile-error form
                           (if (symbolp bad)
                             "slot name ~s isn't a bindable symbol"
                             "invalid slot specifier syntax: ~s")
                           bad))
          (each ((s supers))
            (or (find-struct-type s)
                (compile-defr-warning form ^(struct-type . ,s)
                                      "inheritance base ~s \
                                      \ does not name a struct type"
                                      s)))
          (let ((arg-sym (gensym))
                (type-sym (gensym)))
            (register-tentative-def ^(struct-type . ,name))
            (each ((s stat-slots))
              (register-tentative-def ^(slot . ,s)))
            (each ((s inst-slots))
              (register-tentative-def ^(slot . ,s)))
            ^(sys:make-struct-type
               ',name ',supers ',stat-slots ',inst-slots
               ,(if (or func-si-forms val-si-forms)
                   ^(lambda (,arg-sym)
                      ,*(mapcar (aret ^(when (static-slot-p ,arg-sym ',@2)
                                         (static-slot-set ,arg-sym ',@2 ,@3)))
                                (append func-si-forms val-si-forms))))
               ,(if (or inst-si-forms instance-init-forms
                        instance-fini-forms instance-postfini-forms)
                  ^(lambda (,arg-sym)
                     ,*(if instance-fini-forms
                         ^((finalize ,arg-sym
                                     (sys:meth-lambda ,name :fini (,arg-sym)
                                       ,*(append-each ((iff instance-fini-forms))
                                           ^((let ((,(car iff) ,arg-sym))
                                               ,*(cdr iff)))))
                                     t)))
                     ,*(if instance-postfini-forms
                         ^((finalize ,arg-sym
                                     (sys:meth-lambda ,name :postfini (,arg-sym)
                                       ,*(append-each ((iff (nreverse instance-postfini-forms)))
                                           ^((let ((,(car iff) ,arg-sym))
                                               ,*(cdr iff))))))))
                     ,*(if inst-si-forms
                         ^((let ((,type-sym (struct-type ,arg-sym)))
                             ,*(mapcar (aret ^(unless (static-slot-p ,type-sym ',@2)
                                                (slotset ,arg-sym ',@2 ,@3)))
                                       inst-si-forms))))
                     ,*(append-each ((iif (nreverse instance-init-forms)))
                         ^((symacrolet ((%fun% '(,name :init)))
                             (let ((,(car iif) ,arg-sym))
                               ,*(cdr iif)))))))
               ,(when args
                  (when (> (countql : args) 1)
                    (compile-error form
                                   "multiple colons in boa syntax"))
                  (let ((col-pos (posq : args)))
                    (let ((req-args [args 0..col-pos])
                          (opt-args (if col-pos [args (succ col-pos)..:])))
                      (let ((r-gens (mapcar (ret (gensym)) req-args))
                            (o-gens (mapcar (ret (gensym)) opt-args))
                            (p-gens (mapcar (ret (gensym)) opt-args)))
                        ^(lambda (,arg-sym ,*r-gens
                                  ,*(if opt-args '(:))
                                  ,*(if opt-args
                                      (mapcar (ret ^(,@1 nil ,@2))
                                              o-gens p-gens)))
                           ,*(mapcar (ret ^(set (qref  ,arg-sym ,@1) ,@2))
                                     req-args r-gens)
                           ,*(mapcar (ret ^(if ,@3
                                             (set (qref ,arg-sym ,@1) ,@2)))
                                     opt-args o-gens p-gens))))))
               ,(if instance-postinit-forms
                  ^(sys:meth-lambda ,name :postinit (,arg-sym)
                     ,*(append-each ((ipf (nreverse instance-postinit-forms)))
                         ^((let ((,(car ipf) ,arg-sym))
                             ,*(cdr ipf)))))))))))))

(defmacro sys:struct-lit (name . plist)
  ^(sys:make-struct-lit ',name ',plist))

(defun sys:check-slot (form slot)
  (unless (or (sys:slot-types slot)
              (sys:static-slot-types slot))
    (compile-defr-warning form ^(slot . ,slot)
                          "~s isn't the name of a struct slot"
                          slot))
  slot)

(defun sys:check-struct (form stype)
  (unless (find-struct-type stype)
    (compile-defr-warning form ^(struct-type . ,stype)
                          "~s does not name a struct type"
                          stype)))

(defmacro qref (:form form obj . refs)
  (when (null refs)
    (throwf 'eval-error "~s: bad syntax" 'qref))
  (tree-case obj
    ((a b) (if (eq a 't)
             (let ((s (gensym)))
               ^(slet ((,s ,b))
                  (if ,s (qref ,s ,*refs))))
             :))
    (t (tree-case refs
         (() ())
         (((pref sym) . more)
           (if (eq pref t)
             (let ((s (gensym)))
               ^(let ((,s (qref ,obj ,sym)))
                  (if ,s (qref ,s ,*more))))
             :))
         (((dw sym . args))
          (if (eq dw 'dwim)
            (let ((osym (gensym)))
              (sys:check-slot form sym)
              ^(slet ((,osym ,obj))
                 ,(if (and (plusp sys:compat) (<= sys:compat 251))
                    ^[(slot ,osym ',sym) ,*args]
                    ^[(slot ,osym ',sym) ,osym ,*args])))
            :))
         (((dw sym . args) . more)
          (if (eq dw 'dwim)
            (let ((osym (gensym)))
              (sys:check-slot form sym)
              ^(qref (slet ((,osym ,obj))
                       ,(if (and (plusp sys:compat) (<= sys:compat 251))
                          ^[(slot ,osym ',sym) ,*args]
                          ^[(slot ,osym ',sym) ,osym ,*args])) ,*more))
            :))
         (((sym . args))
          (let ((osym (gensym)))
            (sys:check-slot form sym)
            ^(slet ((,osym ,obj))
               (call (slot ,osym ',sym) ,osym ,*args))))
         (((sym . args) . more)
          (let ((osym (gensym)))
            (sys:check-slot form sym)
            ^(qref (slet ((,osym ,obj))
                     (call (slot ,osym ',sym) ,osym ,*args)) ,*more)))
         ((sym)
          (sys:check-slot form sym)
          ^(slot ,obj ',sym))
         ((sym . more)
          (sys:check-slot form sym)
          ^(qref (slot ,obj ',sym) ,*more))
         (else (throwf 'eval-error "~s: bad syntax: ~s" 'qref else))))))

(defmacro uref (. args)
  (cond
    ((null args) (throwf 'eval-error "~s: bad syntax" 'uref))
    ((null (cdr args))
     (if (consp (car args))
       ^(umeth ,*(car args))
       ^(usl ,(car args))))
    ((eq t (car args))
     (with-gensyms (ovar)
       ^(lambda (,ovar) (qref (t ,ovar) ,*(cdr args)))))
    (t (with-gensyms (ovar)
         ^(lambda (,ovar) (qref ,ovar ,*args))))))

(defun sys:new-type (op form type)
  (caseq op
    ((new lnew) (sys:check-struct form type) ^',type)
    (t type)))

(defun sys:new-expander (op form spec pairs)
  (when (oddp (length pairs))
    (compile-error form "slot initform arguments must occur pairwise"))
  (let ((qpairs (mappend (aret ^(',@1 ,@2)) (tuples 2 pairs))))
    (tree-case spec
      ((texpr . args)
       (if (and (eq texpr 'dwim)
                (meq op 'new* 'lnew*))
         :
         (let ((type (sys:new-type op form texpr)))
           (caseq op
             ((new new*) (if qpairs
                           ^(make-struct ,type (list ,*qpairs) ,*args)
                           ^(struct-from-args ,type ,*args)))
             ((lnew lnew*) ^(make-lazy-struct ,type
                                              (lambda ()
                                                (cons (list ,*qpairs)
                                                      (list ,*args)))))))))
      (texpr
        (let ((type (sys:new-type op form texpr)))
          (caseq op
            ((new new*) ^(struct-from-plist ,type ,*qpairs))
            ((lnew lnew*) ^(make-lazy-struct ,type
                                             (lambda ()
                                               (list (list ,*qpairs)))))))))))

(defmacro new (:form form spec . pairs)
  (sys:new-expander (car form) form spec pairs))

(defmacro new* (:form form spec . pairs)
  (sys:new-expander (car form) form spec pairs))

(defmacro lnew (:form form spec . pairs)
  (sys:new-expander (car form) form spec pairs))

(defmacro lnew* (:form form spec . pairs)
  (sys:new-expander (car form) form spec pairs))

(defmacro meth (obj slot . bound-args)
  ^[(fun method) ,obj ',slot ,*bound-args])

(defmacro usl (:form form slot)
  (sys:check-slot form slot)
  ^(uslot ',slot))

(defmacro umeth (:form form slot . bound-args)
  (sys:check-slot form slot)
  ^[(fun umethod) ',slot ,*bound-args])

(defun sys:define-method (type-sym name fun)
  (caseq name
    (:init (struct-set-initfun type-sym fun))
    (:postinit (struct-set-postinitfun type-sym fun))
    (t (static-slot-ensure type-sym name fun)))
  ^(meth ,type-sym ,name))

(defmacro defmeth (:form form type-sym name arglist . body)
  (cond
    ((not (bindable type-sym))
      (compile-error form "~s isn't a valid struct name" type-sym))
    ((not (find-struct-type type-sym))
      (compile-defr-warning form ^(struct-type . ,type-sym)
                            "definition of struct ~s not seen here" type-sym)))
  (register-tentative-def ^(slot . ,name))
  ^(sys:define-method ',type-sym ',name (sys:meth-lambda ,type-sym ,name
                                                         ,arglist
                                          (block ,name ,*body))))

(defmacro with-slots ((. slot-specs) obj-expr . body)
  (with-gensyms (obj-sym)
    ^(let ((,obj-sym ,obj-expr))
       (symacrolet (,*(mapcar [iff consp
                                   (aret ^(,@1 (slot ,obj-sym ',@2)))
                                   (ret ^(,@1 (slot ,obj-sym ',@1)))]
                              slot-specs))
         ,*body))))

(defun sys:rslotset (struct sym meth-sym val)
  (prog1
    (slotset struct sym val)
    (call (umethod meth-sym) struct)))

(defmacro usr:rslot (struct sym t)
  ^(slot ,struct ,sym))

(define-place-macro usr:rslot (struct sym meth-sym)
  ^(sys:rslot ,struct ,sym ,meth-sym))

(defplace (sys:rslot struct sym meth-sym) body
  (getter setter
    (with-gensyms (struct-sym slot-sym meth-slot-sym)
      ^(slet ((,struct-sym ,struct)
              (,slot-sym ,sym)
              (,meth-slot-sym ,meth-sym))
         (macrolet ((,getter () ^(slot ,',struct-sym ,',slot-sym))
                    (,setter (val) ^(sys:rslotset ,',struct-sym ,',slot-sym
                                                  ,',meth-slot-sym ,val)))
           ,body))))
  (ssetter
    ^(macrolet ((,ssetter (val) ^(progn
                                   (sys:rslotset ,',struct ,',sym
                                             ,',meth-sym ,val))))
       ,body)))

(defmacro define-struct-clause (:form form keyword (. params) . body)
  (if (meq keyword :static :instance :function :method
           :init :postinit :fini :postfini :inherit)
    (compile-error form "~s is a reserved defstruct clause keyword" keyword))
  (unless (keywordp keyword)
    (compile-error form "~s: clauses must be named by keyword symbols" keyword))
  (with-gensyms (slot form)
    ^(progn
       (set [*struct-clause-expander* ,keyword]
          (lambda (,slot ,form)
            (mac-param-bind ,form ,params (cdr ,slot) ,*body)))
       ,keyword)))

(defun macroexpand-struct-clause (clause : form)
  (iflet ((xfun (and (consp clause) [*struct-clause-expander* (car clause)])))
    [xfun clause form]
    (cons clause nil)))

(defmacro define-struct-prelude (:form form prelude-name struct-names . clauses)
  (unless (bindable prelude-name)
    (compile-error form "~s isn't a valid prelude name" prelude-name))
  (when (bindable struct-names)
    (set struct-names (list struct-names)))
  (each ((sname struct-names))
    (unless (bindable sname)
      (compile-error form "~s isn't a valid struct name" sname))
    (let* ((cell (inhash *struct-prelude-alists* sname nil))
           (alist (aconsql-new prelude-name clauses (cdr cell))))
      (rplacd cell alist)
      (set [*struct-prelude* sname] [mappend cdr (reverse alist)]))
    nil))

(compile-only
  (load-for (struct sys:param-parser-base "param")))

(define-struct-clause :delegate (:form form
                                 meth-name params delegate-expr
                                 : (target-method meth-name))
  (unless params
    (compile-error form "delegate method requires at least one argument"))
  (let* ((obj (car params))
         (pp (new (fun-param-parser (cdr params) form)))
         (opt pp.(opt-syms))
         (args (append pp.req opt pp.rest)))
    ^((:method ,meth-name
        (,obj ,*pp.req
              ,*(if opt
                  (cons : (collect-each ((o pp.opt))
                            (tree-case o
                              ((sym) ^(,sym :))
                              ((t t) o)
                              ((t t t)
                               (compile-error form
                                              "~s: three-element optional \ \
                                              parameter ~s not supported"
                                              o))))))
              ,*pp.rest)
        (qref ,delegate-expr (,target-method ,*args))))))

(define-struct-clause :mass-delegate (:form form self-var delegate-expr
                                      from-struct . methods)
  (let ((from-type (find-struct-type from-struct)))
    (flet ((is-meth (slot)
             (and (static-slot-p from-type slot)
                  (let ((f (static-slot from-type slot)))
                    (and (functionp f)
                         (plusp (fun-fixparam-count f)))))))
      (unless from-type
        (compile-error form "~s doesn't name a struct type" from-struct))
      (if (starts-with '(*) methods)
        (set methods
             (diff [keep-if is-meth (slots from-type)]
                   (cdr methods)))
        (iflet ((badmeth [remove-if is-meth methods]))
          (compile-error form "~s aren't methods of type ~s" badmeth from-struct)))
      (collect-each ((m methods))
        (let* ((f (static-slot from-type m))
               (fix (fun-fixparam-count f))
               (opt (fun-optparam-count f))
               (var (fun-variadic f))
               (parms ^(,*(take (- fix opt) (cons self-var (gun (gensym))))
                        ,*(if (plusp opt)
                            ^(: ,*(take opt (gun (gensym)))))
                        ,*(if var (gensym)))))
          ^(:delegate ,m ,parms ,delegate-expr))))))