@@ 1,4 1,4 @@
-;; Copyright 2020 Linus Björnstam
+;; Copyright 2020, 2021 Linus Björnstam
;;
;; Permission to use, copy, modify, and/or distribute this software for any
;; purpose with or without fee is hereby granted, provided that the above
@@ 6,13 6,13 @@
;; The software is provided "as is", without any express or implied warranties.
;;
;; Fix guile to have definitions in expression context in most common constructs.
-;; nothing for srfi-11 so far. This is written using syntax-rules and should
-;; be portable across implementation.
+;; For guile 3 it should have no overhead, for guile 2 the code produced is slower
+;; than the same code using let or let* due to guile 2 not optimizing letrec or
+;; internal definitions.
(define-module (syntax define)
- #:use-module (ice-9 receive)
#:replace ((new-lambda . lambda)
(new-define . define)
(new-begin . begin)
@@ 20,65 20,101 @@
(new-let* . let*)
(let-letrec . letrec)
(new-letrec* . letrec*)
+ (new-when . when)
+ (new-unless . unless)
(new-case . case)
- (new-cond . cond)
- ))
+ (new-cond . cond)))
(define-syntax new-lambda
(syntax-rules ()
((_ formals body body* ...)
- (lambda formals (new-begin body body* ...)))))
+ (lambda formals (parse-body (lambda formals body body* ...) body body* ...)))))
(define-syntax new-define
(syntax-rules ()
- ((_ (name args ...) body body* ...)
- (define name (new-lambda (args ...) body body* ...)))
+ ((_ (stuff ...) body body* ...)
+ (define (stuff ...) (parse-body (define (stuff ...) body body* ...) body body* ...)))
((_ name expr) (define name expr))))
(define-syntax new-begin
(syntax-rules ()
+ ((_) (if #f #f))
((_ one-thing-only)
one-thing-only)
((_ stuff ...)
- (%parse-body () stuff ...))))
+ (parse-body () stuff ...))))
(define-syntax new-let
(syntax-rules ()
- ((_ clauses body body* ...)
- (let clauses (new-begin body body* ...)))))
+ ((_ (clauses ...) body body* ...)
+ (let (clauses ...) (parse-body (let (clauses ...) body body* ...) body body* ...)))
+ ((_ name (clauses ...) body body* ...)
+ (let name (clauses ...)
+ (parse-body (let name (clauses ...) body body* ...) body body* ...)))
+ ((_ err ...) (syntax-error "Bad let form"))))
(define-syntax new-let*
(syntax-rules ()
- ((_ clauses body body* ...)
- (let* clauses (new-begin body body* ...)))))
+ ((_ (clauses ...) body body* ...)
+ (let* (clauses ...) (parse-body (let (clauses ...) body body* ...) body body* ...)))
+ ((_ err ...) (syntax-error "Bad let* form"))))
(define-syntax new-letrec
(syntax-rules ()
((_ clauses body body* ...)
- (letrec clauses (new-begin body body* ...)))))
+ (letrec clauses
+ (parse-body (letrec clauses body body* ...) body body* ...)))
+ ((_ err ...) (syntax-error "Bad letrec form"))))
(define-syntax new-letrec*
(syntax-rules ()
((_ clauses body body* ...)
- (letrec* clauses (new-begin body body* ...)))))
+ (letrec* clauses
+ (parse-body (letrec* clauses body body* ...) body body* ...)))
+ ((_ err ...) (syntax-error "Bad letrec* form"))))
(define-syntax new-case
+ (syntax-rules ()
+ ((_ key clauses ...)
+ (nca (case clauses ...) key () clauses ...))
+ ((_ err ...) (syntax-error "Bad case form"))))
+
+(define-syntax new-when
+ (syntax-rules ()
+ ((_ test body body* ...)
+ (when test (parse-body (when test body body* ...) body body* ...)))
+ ((err ...) (syntax-error "Bad when form"))))
+
+(define-syntax new-unless
+ (syntax-rules ()
+ ((_ test body body* ...)
+ (unless test (parse-body (unless test body body* ...) body body* ...)))
+ ((err ...) (syntax-error "Bad unless form"))))
+
+
+
+(define-syntax nca
(syntax-rules (else =>)
- ;; Special case for else with a lambda-clause.
- ((_ expr
- (test body ...)
- (else => else-body ...))
- (case expr
- (test (new-begin body ...))
- (else => (new-begin else-body ...))))
- ((_ expr
- (test body ...) ...)
- (case expr
- (test (new-begin body ...)) ...))))
+ ((_ o k (clauses ...))
+ (case k clauses ...))
+ ((_ o k (c ...) (else => expr))
+ (nca o k (c ... (else => expr))))
+ ;; error checking the else clause:
+ ((_ o k c (else => expr ...) more ...)
+ (syntax-error "Malformed else clause" o))
+ ((_ o k (c ...) (d => expr) . rest)
+ (nca o k (c ... (d => expr)) . rest))
+ ;; error checking the lambda clause
+ ((_ o k c (d => expr ...) . rest)
+ (syntax-error "Malformed case clause in form " (d => expr ...) o))
+ ((_ o k (c ...) (d expr exprs ...) . rest)
+ (nca o k (c ... (d (parse-body o expr exprs ...))) . rest))
+ ((_ o stuff ...) (syntax-error "Error in form " o))
+ ((_ o err ...) (syntax-error "Bad case form" o))))
@@ 87,63 123,54 @@
;; cond. Guile supports a non-standard guard-case. This should be removed
;; if porting to any other scheme.
(define-syntax new-cond
- (syntax-rules (=> else)
- ;; Guile-specific guard case
- ((_ (test guard => body ...) rest ...)
- (receive vals test
- (if (apply guard vals)
- (apply (new-begin body ...) vals)
- (new-cond rest ...))))
+ (syntax-rules ()
+ ((_ clauses ...)
+ (nc (cond clauses ...) () clauses ...))))
- ;; Lambda case
- ((_ (test => body ...) rest ...)
- (let ((temp test))
- (if test
- ((new-begin body ...) temp)
- (internal-cond rest ...))))
+(define-syntax nc
+ (syntax-rules (else =>)
+ ((nc o (clauses ...))
+ (cond clauses ...))
+ ((nc o (c ...) (else body ...))
+ (nc o (c ... (else (parse-body o body ...)))))
+ ((nc o (c ...) (test => expr) . rest)
+ (nc o (c ... (test => expr)) . rest))
+ ((nc o (c ...) (test guard => expr) . rest)
+ (nc o (c ... (test guard => expr)) . rest))
+ ((nc o (c ...) (test body body* ...) . rest)
+ (nc o (c ... (test (parse-body o body body* ...))) . rest))
- ;; Else case
- ((_ (else body ...))
- (new-begin body ...))
-
- ;; No clauses left and no else clause.
- ((_) (if #f #f))
-
- ;; Normal case
- ((_ (test body ...) rest ...)
- (if test
- (new-begin body ...)
- (new-cond rest ...)))))
+ ;; Error clauses
+ ((nc o (c ...) (else body ...) error-clause error-clause* ...)
+ (syntax-error "Else must be the last clause of a cond in form " o))
+ ((_ o err ...) (syntax-error "Bad cond form" o))))
-;;(%parse-define (clauses ...) body ...)
-(define-syntax %parse-define
+(define-syntax parse-body
(syntax-rules (new-define)
- ;; procedure definition
- ((_ (clauses ...) (new-define (name args ...) body body* ...) rest ... )
- (%parse-define (clauses ... (name (new-lambda (args ...) body body* ...))) rest ... ))
+ ((_ orig stuff ... (new-define stuff2 ...))
+ (syntax-error "Body should end with an expression in form " orig))
+ ((_ orig body ...)
+ (pb2 orig () () body ...))))
- ;; Variable definition
- ((_ (clauses ...) (new-define name expr) rest ...)
- (%parse-define (clauses ... (name expr)) rest ...))
+(define-syntax pb2
+ (syntax-rules (new-define)
+ ((pb2 orig () (expr ...) expr*)
+ (begin expr ... expr*))
+ ((pb2 orig (clauses ...) (expr ...) expr*)
+ (letrec (clauses ...) expr ... expr*))
- ;; Exit
- ((_ clauses rest ...)
- (letrec* clauses
- (%parse-body () rest ...)))))
+
+ ((pb2 orig (clauses ...) () (new-define (name args ...) body ...) . rest)
+ (pb2 orig (clauses ... (name (new-lambda (args ...) body ...))) () . rest))
+ ((pb2 o (clauses ...) () (new-define var body ...) . rest)
+ (pb2 o (clauses ... (var (new-begin body ...))) () . rest))
-;; A macro that transverses expressions
-;; (%parse-body (seen-exprssions ...) rest ...)
-(define-syntax %parse-body
- (syntax-rules (new-define)
- ;; Found no definitions. Just exit
- ((_ (exprs ...))
- (begin exprs ...))
- ;; A definition, exit to %parse-define
- ((_ (exprs ...) (new-define stuff ...) rest ...)
- (begin exprs ... (%parse-define () (new-define stuff ...) rest ... )))
- ;; Just a new expression.
- ((_ (exprs ...) new-expr rest ...)
- (%parse-body (exprs ... new-expr) rest ...))))
+ ((pb2 orig (clauses ...) (expr ...) (new-define (name args ...) body ...) . rest)
+ (pb2 orig (clauses ... (_ (begin expr ...)) (name (new-lambda (args ...) body ...))) () . rest))
+ ((pb2 o (clauses ...) (expr ...) (new-define var body ...) . rest)
+ (pb2 o (clauses ... (_ (begin expr ...)) (var (new-begin body ...))) () . rest))
+ ((pb2 o (clauses ...) (expr ...) expr* . rest)
+ (pb2 o (clauses ...) (expr ... expr*) . rest))))