From 895c236f70ecc3b0fbb04eab7d1330796e0610e6 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Fri, 17 Jan 2025 06:15:31 -0800
Subject: New macro: lop1.

* autoload.c (op_set_entries): Autoload on lop1 symbol.

* stldlib/op.tl (sys:op-expand): Add lop1 case.
(sys:opip-expand): Add lop1 to the list of operators
that are recgonized and specially treated.
(lop1): New macro.

* tests/012/op.tl: New tests.

* txr.1: Documented.
---
 autoload.c      |  2 +-
 stdlib/op.tl    | 12 +++++++++++-
 tests/012/op.tl | 13 +++++++++++++
 txr.1           | 42 +++++++++++++++++++++++++++++++++++++++++-
 4 files changed, 66 insertions(+), 3 deletions(-)

diff --git a/autoload.c b/autoload.c
index bf5e7602..9808c141 100644
--- a/autoload.c
+++ b/autoload.c
@@ -713,7 +713,7 @@ static val op_set_entries(val fun)
 {
   val name[] = {
     lit("op"), lit("do"), lit("lop"), lit("ldo"), lit("ap"), lit("ip"),
-    lit("ado"), lit("ido"), lit("ret"), lit("aret"),
+    lit("lop1"), lit("ado"), lit("ido"), lit("ret"), lit("aret"),
     lit("opip"), lit("oand"), lit("lopip"), lit("loand"),
     lit("opf"), lit("lopf"), lit("flow"), lit("lflow"), lit("tap"),
     nil
diff --git a/stdlib/op.tl b/stdlib/op.tl
index a3a0135e..b443a2d2 100644
--- a/stdlib/op.tl
+++ b/stdlib/op.tl
@@ -172,6 +172,13 @@
                                  ;; no cadr here to avoid circular autoload
                                  ^[sys:apply ,(car (cdr syntax-2))
                                              (append ,rest-sym (list ,*fargs-l1))]))
+                              ((and (eq sym 'lop1) fargs)
+                               (let ((fargs-l1 (mapcar (lambda (farg)
+                                                         ^(sys:l1-val ,farg))
+                                                       fargs))
+                                     (arg1 (sys:ensure-op-arg ctx 1)))
+                                 ;; no cadr here to avoid circular autoload
+                                 ^[,(car (cdr syntax-2)) ,arg1 ,*fargs-l1]))
                               (metas syntax-2)
                               ((eq sym 'do)
                                (let ((arg1 (sys:ensure-op-arg ctx 1)))
@@ -199,6 +206,9 @@
 (defmacro lop (:form f :env e . args)
   (sys:op-expand f e args))
 
+(defmacro lop1 (:form f :env e . args)
+  (sys:op-expand f e args))
+
 (defmacro ldo (op . args)
   ^(do ,op @1 ,*args))
 
@@ -243,7 +253,7 @@
        (cons c (sys:opip-expand e opsym dosym rest))
        (let ((sym (car c)))
          (cond
-           ((memq sym '(dwim uref qref op do lop ldo ap ip ado ido ret aret))
+           ((memq sym '(dwim uref qref op do lop lop1 ldo ap ip ado ido ret aret))
             (cons c (sys:opip-expand e opsym dosym rest)))
            ((sys:opip-single-let-p c)
             (tree-bind (t sym) c
diff --git a/tests/012/op.tl b/tests/012/op.tl
index 34f7ef39..6bda45a0 100644
--- a/tests/012/op.tl
+++ b/tests/012/op.tl
@@ -52,6 +52,19 @@
   (fi (lop list @42 @rest)) (42 t)
   (fi (lop list @1 @3 @rest @2)) (3 t))
 
+'(mtest
+  (fi (lop1)) :error
+  (fi (lop1 list)) (0 t)
+  (fi (lop1 list @1)) (1 t)
+  (fi (lop1 list @2)) (2 t)
+  (fi (lop1 list @42)) (42 t)
+  (fi (lop1 list @rest)) (0 t)
+  (fi (lop1 list @1 @rest)) (1 t)
+  (fi (lop1 list @2 @rest)) (2 t)
+  (fi (lop1 list @42 @rest)) (42 t)
+  (fi (lop1 list @1 @3 @rest @2)) (3 t))
+
+
 (mtest
   [(do quote x) 3] :error
   [(do quote @1) 3] :error
diff --git a/txr.1 b/txr.1
index 0f353b97..85116591 100644
--- a/txr.1
+++ b/txr.1
@@ -60438,7 +60438,7 @@ is equivalent to
 
 Likewise, if any meta-number arguments or
 .code @rest
-are represent,
+are present,
 .code lop
 is equivalent to
 .codn op .
@@ -60534,6 +60534,45 @@ equivalence above is instead:
 
 .brev
 
+.coNP Macro @ lop1
+.synb
+.mets (lop1 << form +)
+.syne
+.desc
+The
+.code lop1
+macro is variant of
+.codn lop .
+
+The
+.code lop1
+macro is equivalent to
+.code op
+under all the same conditions as
+.codn lop .
+
+If two or more
+.metn form s
+are specified, and none of the forms mention any
+meta-number arguments or
+.codn @rest ,
+then
+.code lop1
+produces a function of one parameter, which
+inserts the argument value into the leftmost position
+of the function being applied.
+
+In contrast, under the same conditions, the
+.code lop
+macro produces a variadic function which inserts
+all of its arguments into that position.
+
+Note:
+.code lop1
+provides a useful optimization in situations when it is known that the
+resulting function will be called with exactly one argument.  It eliminates
+argument list splicing logic.
+
 .coNP Macro @ ldo
 .synb
 .mets (ldo < oper << form *)
@@ -60721,6 +60760,7 @@ notation denotes the following transformation applied to each argument:
   (op ...)       -> (op ...)
   (do ...)       -> (do ...)
   (lop ...)      -> (lop ...)
+  (lop1 ...)     -> (lop1 ...)
   (ldo ...)      -> (ldo ...)
   (ap ...)       -> (ap ...)
   (ip ...)       -> (ip ...)
-- 
cgit v1.2.3