changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/std/macs/pan.lisp

changeset 594: 5bd0eb9fa1fa
parent: 83f8623a6ec3
author: Richard Westhaver <ellis@rwest.io>
date: Wed, 14 Aug 2024 21:49:56 -0400
permissions: -rw-r--r--
description: rocksdb callbacks, missing symbol fixes 
     1 ;;; pan.lisp --- Pandoric macros
     2 
     3 ;;; Code:
     4 (in-package :std/macs)
     5 (in-readtable :std)
     6 
     7 (defun pandoriclet-get (letargs)
     8   `(case sym
     9      ,@(mapcar #`(((car ,a1)) (car ,a1))
    10         letargs)
    11      (t (error
    12          "Unknown pandoric get: ~a"
    13          sym))))
    14 
    15 (defun pandoriclet-set (letargs)
    16   `(case sym
    17      ,@(mapcar #`(((car ,a1))
    18                   (setq (car ,a1) val))
    19         letargs)
    20      (t (error
    21          "Unknown pandoric set: ~a"
    22          sym))))
    23 
    24 (defmacro pandoriclet (letargs &rest body)
    25   (let ((letargs (cons
    26                   '(%a)
    27                   (std/list:let-binding-transform
    28                    letargs))))
    29     `(let (,@letargs)
    30        (setq %a ,@(last body))
    31        ,@(butlast body)
    32        (dlambda
    33         (:pandoric-get (sym)
    34                        ,(pandoriclet-get letargs))
    35         (:pandoric-set (sym val)
    36                        ,(pandoriclet-set letargs))
    37         (t (&rest args)
    38            (apply %a args))))))
    39 
    40 (declaim (inline get-pandoric))
    41 
    42 (defun get-pandoric (box sym)
    43   (funcall box :pandoric-get sym))
    44 
    45 (defsetf get-pandoric (box sym) (val)
    46   `(progn
    47      (funcall ,box :pandoric-set ,sym ,val)
    48      ,val))
    49 
    50 (defmacro! with-pandoric (syms o!box &rest body)
    51   `(symbol-macrolet
    52        (,@(mapcar #`(,a1 (get-pandoric ,g!box ,a1))
    53                   syms))
    54      ,@body))
    55 
    56 ;; (defun pandoric-hotpatch (box new)
    57 ;;   (with-pandoric (%a) box
    58 ;;     (setq %a new)))
    59 
    60 (defmacro pandoric-recode (vars box new)
    61   `(with-pandoric (%a ,@vars) ,box
    62      (setq %a ,new)))
    63 
    64 (defmacro plambda (largs pargs &rest body)
    65   (let ((pargs (mapcar #'list pargs)))
    66     `(let (%a %p)
    67        (setq
    68         %a (lambda ,largs ,@body)
    69         %p (dlambda
    70               (:pandoric-get (sym)
    71                              ,(pandoriclet-get pargs))
    72               (:pandoric-set (sym val)
    73                              ,(pandoriclet-set pargs))
    74               (t (&rest args)
    75                  (apply %a args)))))))
    76 
    77 (defvar pandoric-eval-tunnel)
    78 
    79 (defmacro pandoric-eval (vars expr)
    80   `(let ((pandoric-eval-tunnel
    81            (plambda () ,vars t)))
    82      (eval `(with-pandoric
    83               ,',vars pandoric-eval-tunnel
    84               ,,expr))))