IF OBJECT_ID('Pairs', 'U') IS NOT NULL
DROP TABLE Pairs
GO

CREATE TABLE Pairs
(
  ID int IDENTITY(0,1) PRIMARY KEY,
  CAR int,
  CDR int
);
GO

IF OBJECT_ID('Symbols', 'U') IS NOT NULL
DROP TABLE Symbols
GO

CREATE TABLE Symbols
(
  ID int IDENTITY(0,1) PRIMARY KEY,
  Name VARCHAR(255) NOT NULL,
  Value INT NOT NULL
);
GO

IF OBJECT_ID('Functions', 'U') IS NOT NULL
DROP TABLE Functions
GO

CREATE TABLE Functions
(
  ID int IDENTITY(0,1) PRIMARY KEY,
  SEXP INT
);
GO

CREATE UNIQUE NONCLUSTERED INDEX IX_Name ON Symbols
(
	Name ASC
)WITH (PAD_INDEX  = OFF, STATISTICS_NORECOMPUTE  = OFF, SORT_IN_TEMPDB = OFF, IGNORE_DUP_KEY = OFF, DROP_EXISTING = OFF, ONLINE = OFF, ALLOW_ROW_LOCKS  = ON, ALLOW_PAGE_LOCKS  = ON) ON [PRIMARY]
GO


IF OBJECT_ID('cons', 'P') IS NOT NULL
DROP PROCEDURE cons
GO

CREATE PROCEDURE cons (@CAR INT, @CDR INT)
AS BEGIN
    SET NOCOUNT ON;
    DECLARE @ResultTable TABLE(Value INT)
    INSERT INTO Pairs (CAR, CDR)
    OUTPUT Inserted.ID INTO @ResultTable -- gets the ID of new cons-pair
    VALUES (@CAR, @CDR)
    RETURN (SELECT Value FROM @ResultTable)*8 + 1
END
GO

IF OBJECT_ID('uncons', 'P') IS NOT NULL
DROP PROCEDURE uncons
GO

CREATE PROCEDURE uncons (@ID INT, @CAR INT OUT, @CDR INT OUT)
AS BEGIN
    SET @ID = @ID/8
    SELECT @CAR = CAR, @CDR = CDR FROM Pairs WHERE ID = @ID
END
GO

IF OBJECT_ID('typeof', 'P') IS NOT NULL
DROP PROCEDURE typeof
GO

CREATE PROCEDURE typeof (@ID INT)
AS RETURN (@ID & 7)
GO

IF OBJECT_ID('reverse_list', 'P') IS NOT NULL
DROP PROCEDURE reverse_list
GO

CREATE PROCEDURE reverse_list (@Xs INT)
AS BEGIN
    DECLARE @Ys INT
    DECLARE @X INT
    SET @Ys = 1
    WHILE @Xs <> 1
      BEGIN
        EXEC uncons @Xs, @X OUT, @Xs OUT
        EXEC @Ys = cons @X, @Ys
      END
    RETURN @Ys
END
GO

IF OBJECT_ID('intern', 'P') IS NOT NULL
DROP PROCEDURE intern
GO

CREATE PROCEDURE intern (@Name VARCHAR(255))
AS BEGIN
    SET NOCOUNT ON;
    DECLARE @Result INT
    SELECT @Result = ID FROM Symbols WHERE Name = @Name
    IF @Result IS NULL
      BEGIN
        DECLARE @ResultTable TABLE(Value INT)
        INSERT INTO Symbols (Name, Value)
        OUTPUT Inserted.ID INTO @ResultTable -- gets the ID of new symbol
        VALUES (@Name, 1)
        SELECT @Result=Value FROM @ResultTable
      END
    RETURN @Result*8 + 2
END
GO

IF OBJECT_ID('make_function', 'P') IS NOT NULL
DROP PROCEDURE make_function
GO
    
CREATE PROCEDURE make_function (@SEXP INT)
AS BEGIN
    SET NOCOUNT ON;
    DECLARE @ResultTable TABLE(Value INT)
    INSERT INTO Functions (SEXP)
    OUTPUT Inserted.ID INTO @ResultTable -- gets the ID of new function
    VALUES (@SEXP)
    RETURN (SELECT Value FROM @ResultTable)*8 + 3
END
GO


IF OBJECT_ID('function_sexp', 'P') IS NOT NULL
DROP PROCEDURE function_sexp
GO
    
CREATE PROCEDURE function_sexp (@ID INT)
AS BEGIN
    SET @ID = @ID/8
    RETURN (SELECT SEXP FROM Functions WHERE ID = @ID)
END
GO

IF OBJECT_ID('symbol_name', 'P') IS NOT NULL
DROP PROCEDURE symbol_name
GO

CREATE PROCEDURE symbol_name (@ID INT, @Name VARCHAR(255) OUT) AS
BEGIN
  SET @ID = @ID/8
  SELECT @Name = Name FROM Symbols WHERE ID = @ID
END
GO

IF OBJECT_ID('symbol_value', 'P') IS NOT NULL
DROP PROCEDURE symbol_value
GO

CREATE PROCEDURE symbol_value (@ID INT) AS
BEGIN
  SET @ID = @ID/8
  RETURN (SELECT Value FROM Symbols WHERE ID = @ID)
END
GO

IF OBJECT_ID('set_symbol_value', 'P') IS NOT NULL
DROP PROCEDURE set_symbol_value
GO

CREATE PROCEDURE set_symbol_value (@ID INT, @Value INT) AS
BEGIN
  SET @ID = @ID/8
  UPDATE Symbols SET Value = @Value WHERE ID = @ID
END
GO

IF OBJECT_ID('parse_number', 'P') IS NOT NULL
DROP PROCEDURE parse_number
GO

CREATE PROCEDURE parse_number (@Chars VARCHAR(64))
AS RETURN CONVERT(INT,@Chars)*8
GO

IF OBJECT_ID('print_sexp', 'P') IS NOT NULL
DROP PROCEDURE print_sexp
GO

CREATE PROCEDURE print_sexp (@SEXP INT, @Result VARCHAR(4000) OUT)
AS BEGIN
    SET @Result = ''
    DECLARE @Type INT
    DECLARE @X INT
    DECLARE @Text VARCHAR(64)
    DECLARE @Tmp VARCHAR(4000)
    EXEC @Type = typeof @SEXP
    IF @Type = 1 -- Pair
      BEGIN
        SET @Result = @Result + '('
        WHILE @SEXP <> 1
          BEGIN
            EXEC uncons @SEXP, @X OUT, @SEXP OUT
            EXEC print_sexp @X, @Tmp OUT
            SET @Result = @Result + @Tmp
            IF @SEXP <> 1 SET @Result = @Result + ' '
          END
        SET @Result = @Result + ')'
      END
    ELSE IF @Type = 2 -- symbol
      BEGIN
        EXEC symbol_name @SEXP, @Text OUT
        SET @Result = @Result + @Text
      END
    ELSE IF @Type = 0 -- number
      BEGIN
        SET @Result = @Result + CONVERT(INT,@SEXP/8)
      END
    ELSE IF @Type = 3 -- function
      BEGIN
        SET @Result = '#function[' + CONVERT(VARCHAR(64),@SEXP/8) + ']'
      END
END
GO

IF OBJECT_ID('read_sexp', 'P') IS NOT NULL
DROP PROCEDURE read_sexp
GO

CREATE PROCEDURE read_sexp (@Cs VARCHAR(4000))
AS BEGIN
    SET NOCOUNT ON
    SET @Cs = REPLACE(REPLACE(@Cs,'+','$add'),'-','$sub')
    DECLARE @Chars VARCHAR(64)
    DECLARE @C VARCHAR(1)
    DECLARE @Stack TABLE(ID INT, Value INT)
    DECLARE @SP INT -- Stack Pointer
    SET @SP = 0
    DECLARE @X INT
    DECLARE @Xs INT
    SET @Xs = 1
    DECLARE @I INT
    SET @I = 0
    DECLARE @E INT
    SET @E = LEN(@Cs)
    WHILE @I < @E BEGIN
        SET @C = SUBSTRING(@Cs,@I+1,1)
        IF PATINDEX('%[0-9a-zA-Z_$*/<>=]%', @C) = 1
          BEGIN
           SET @Chars = ''
            WHILE PATINDEX('%[0-9a-zA-Z_$*/<>=]%', @C) = 1 AND @I < @E
              BEGIN
                SET @Chars = @Chars + @C
                SET @I = @I + 1
                SET @C = SUBSTRING(@Cs,@I+1,1)
              END
            IF @I <> @E SET @I = @I - 1
            IF PATINDEX('%[a-zA-Z_$*/<>=]%', @Chars) = 0
              BEGIN
                EXEC @X = parse_number @Chars
              END
            ELSE
              BEGIN
                SET @Chars = REPLACE(REPLACE(@Chars,'$add','+'),'$sub','-')
                EXEC @X = intern @Chars
              END
            EXEC @Xs = cons @X, @Xs
          END
        ELSE IF @C = '('
          BEGIN
            INSERT INTO @Stack VALUES (@SP, @Xs)
            SET @SP = @SP + 1
            SET @Xs = 1
          END
        ELSE IF @C = ')'
          BEGIN
            SET @SP = @SP - 1
            SELECT @X = Value FROM @Stack WHERE ID = @SP
            DELETE FROM @Stack WHERE ID = @SP
            EXEC @Xs = reverse_list @Xs
            EXEC @Xs = cons @Xs, @X
          END
        ELSE IF @C = ' ' -- ignore
          DECLARE @NOP0 bit
        ELSE
          BEGIN
            PRINT 'ERROR: Invalid char: ' + @C
          END
        SET @I = @I + 1
    END
    EXEC @Xs = reverse_list @Xs
    RETURN @Xs
END
GO

IF OBJECT_ID('eval_sexp', 'P') IS NOT NULL
DROP PROCEDURE eval_sexp
GO

CREATE PROCEDURE eval_sexp (@SEXP INT)
AS BEGIN
    SET NOCOUNT ON
    DECLARE @Result INT
    DECLARE @Type INT
    DECLARE @X INT
    DECLARE @Xs INT
    DECLARE @A INT   -- arg
    DECLARE @As INT  -- args
    DECLARE @V INT   -- value
    DECLARE @Vs INT  -- values
    DECLARE @Body INT
    DECLARE @Save INT
    EXEC @Type = typeof @SEXP
    IF @Type = 1 -- pair
      BEGIN
        IF @SEXP = 1 RETURN 1
        EXEC uncons @SEXP, @X OUT, @Xs OUT
        IF @X = 2 -- quote
          BEGIN
            EXEC uncons @Xs, @Result OUT, @Xs OUT
          END
        ELSE IF @X = 10 -- lambda
          BEGIN
            EXEC uncons @Xs, @X OUT, @Xs OUT
            EXEC @Xs = cons 26, @Xs -- implicit progn
            EXEC @Xs = cons @X, @Xs
            EXEC @Result = make_function @Xs
          END
        ELSE IF @X = 18 -- setq
          BEGIN
            EXEC uncons @Xs, @X OUT, @Xs OUT
            EXEC uncons @Xs, @Result OUT, @Xs OUT
            EXEC @Result = eval_sexp @Result
            EXEC set_symbol_value @X, @Result
            RETURN @Result
          END
        ELSE IF @X = 26 -- progn
          BEGIN
            SET @Result = 1
            WHILE @Xs <> 1 BEGIN
              EXEC uncons @Xs, @X OUT, @Xs OUT
              EXEC @Result = eval_sexp @X
            END
          END
        ELSE IF @X = 34 -- if
          BEGIN
            EXEC uncons @Xs, @X OUT, @Xs OUT
            EXEC @Result = eval_sexp @X
            EXEC uncons @Xs, @X OUT, @Xs OUT
            IF @Result = 1 EXEC uncons @Xs, @X OUT, @Xs OUT
            EXEC @Result = eval_sexp @X
          END
        ELSE -- funcall
          BEGIN
            SET @Vs = 1
            SET @Xs = @SEXP
            WHILE @Xs <> 1 BEGIN
              EXEC uncons @Xs, @X OUT, @Xs OUT
              EXEC @V = eval_sexp @X
              EXEC @Vs = cons @V, @Vs
            END
            EXEC @Vs = reverse_list @Vs
            EXEC uncons @Vs, @X OUT, @Vs OUT
            EXEC @Result = typeof @X
            IF @Result <> 3
              BEGIN
                PRINT 'ERROR: form head is not a function'
                RETURN 1
              END
            IF @X = 3 -- cons
              BEGIN
                EXEC uncons @Vs, @X OUT, @Vs OUT
                EXEC uncons @Vs, @V OUT, @Vs OUT
                EXEC @Result = cons @X, @V
                RETURN @Result
              END
            IF @X = 11 -- car
              BEGIN
                EXEC uncons @Vs, @V OUT, @Vs OUT
                EXEC uncons @V, @Result OUT, @X OUT
                RETURN @Result
              END
            IF @X = 19 -- cdr
              BEGIN
                EXEC uncons @Vs, @V OUT, @Vs OUT
                EXEC uncons @V, @X OUT, @Result OUT
                RETURN @Result
              END
            IF @X = 27 -- list
              BEGIN
                RETURN @Vs
              END
            IF @X = 35 -- +
              BEGIN
                EXEC uncons @Vs, @X OUT, @Vs OUT
                EXEC uncons @Vs, @V OUT, @Vs OUT
                RETURN @X + @V
              END
            IF @X = 43 -- -
              BEGIN
                EXEC uncons @Vs, @X OUT, @Vs OUT
                EXEC uncons @Vs, @V OUT, @Vs OUT
                RETURN @X - @V
              END
            IF @X = 51 -- *
              BEGIN
                EXEC uncons @Vs, @X OUT, @Vs OUT
                EXEC uncons @Vs, @V OUT, @Vs OUT
                RETURN @X * (@V/8)
              END
            IF @X = 59 -- /
              BEGIN
                EXEC uncons @Vs, @X OUT, @Vs OUT
                EXEC uncons @Vs, @V OUT, @Vs OUT
                RETURN (@X/@V)*8
              END
            IF @X = 67 -- =
              BEGIN
                EXEC uncons @Vs, @X OUT, @Vs OUT
                EXEC uncons @Vs, @V OUT, @Vs OUT
                IF @X = @V RETURN 0 -- return something non-NIL
                RETURN 1
              END
            IF @X = 75 -- <
              BEGIN
                EXEC uncons @Vs, @X OUT, @Vs OUT
                EXEC uncons @Vs, @V OUT, @Vs OUT
                IF @X < @V RETURN 0 -- return something non-NIL
                RETURN 1
              END
            IF @X = 83 -- >
              BEGIN
                EXEC uncons @Vs, @X OUT, @Vs OUT
                EXEC uncons @Vs, @V OUT, @Vs OUT
                IF @X > @V RETURN 0 -- return something non-NIL
                RETURN 1
              END
            EXEC @X = function_sexp @X
            EXEC uncons @X, @As OUT, @Body OUT
            SET @Xs = @As
            SET @Save = 1
            WHILE @As <> 1 BEGIN -- setup environment
              EXEC uncons @As, @A OUT, @As OUT
              EXEC uncons @Vs, @V OUT, @Vs OUT
              EXEC @X = symbol_value @A
              EXEC @Save = cons @X, @Save
              EXEC set_symbol_value @A, @V
            END
            EXEC @Result = eval_sexp @Body
            EXEC @Vs = reverse_list @Save
            WHILE @As <> 1 BEGIN -- restore environment
              EXEC uncons @As, @A OUT, @As OUT
              EXEC uncons @Vs, @V OUT, @Vs OUT
              EXEC set_symbol_value @A, @V
            END
          END
      END
    ELSE IF @Type = 2 -- symbol
      BEGIN
        EXEC @Result = symbol_value @SEXP
      END
    ELSE IF @Type = 0 -- number
      BEGIN
        SET @Result = @SEXP
      END
    RETURN @Result
END
GO

IF OBJECT_ID('eval', 'P') IS NOT NULL
DROP PROCEDURE eval
GO


CREATE PROCEDURE eval (@Cs VARCHAR(4000))
AS BEGIN
    DECLARE @Result INT
    EXEC @Result = read_sexp @Cs
    EXEC @Result = cons 26, @Result -- implicit progn
    EXEC @Result = eval_sexp @Result
    RETURN @Result
END
GO


EXEC cons 1, 1 -- NIL
GO

-- Pre-Intern standard symbols, so the get following values
EXEC intern 'quote'   -- 2
EXEC intern 'lambda'  -- 10
EXEC intern 'setq'    -- 18
EXEC intern 'progn'   -- 26
EXEC intern 'if'      -- 34
GO

-- builtin functions stubs
exec eval '(setq cons (lambda () ))'
exec eval '(setq car (lambda () ))'
exec eval '(setq cdr (lambda () ))'
exec eval '(setq list (lambda () ))'
exec eval '(setq + (lambda () ))'
exec eval '(setq - (lambda () ))'
exec eval '(setq * (lambda () ))'
exec eval '(setq / (lambda () ))'
exec eval '(setq = (lambda () ))'
exec eval '(setq < (lambda () ))'
exec eval '(setq > (lambda () ))'
GO

-- predefined functions
exec eval '(setq map (lambda (_f _xs) (if _xs (cons (_f (car _xs)) (map _f (cdr _xs))))))'
exec eval '(setq fac (lambda (n) (if (< n 1) 1 (* n (fac (- n 1))))))'

DECLARE @Text VARCHAR(4000)
DECLARE @Result INT
exec @Result = eval '(fac 5)'
exec print_sexp @Result, @Text OUT
PRINT @Text

exec @Result = eval '(map (lambda (x) (* x x)) (list 1 2 3 4 5))'
exec print_sexp @Result, @Text OUT
PRINT @Text