procedure main(A)
    n := integer(A[1] | 3)    # Max. number of active tasks
    m := integer(A[2] | 2)    # Number of visits by each task
    k := integer(A[3] | 5)    # Number of tasks
    sem := [: |mutex([])\n :]
    every put(threads := [], (i := 1 to k, thread
              every 1 to m do {
                 write("unit ",i," ready")
                 until flag := trylock(!sem)
                 write("unit ",i," running")
                 delay(2000)
                 write("unit ",i," done")
                 unlock(flag)
                 }))

    every wait(!threads)
end


/*REXX pgm computes the 1st N elements of the Lucas sequence for Metallic ratios 0──►9. */
parse arg n bLO bHI digs .                       /*obtain optional arguments from the CL*/
if    n=='' |    n==","  then    n= 15           /*Not specified?  Then use the default.*/
if  bLO=='' |  bLO==","  then  bLO=  0           /* "      "         "   "   "     "    */
if  bHI=='' |  bHI==","  then  bHI=  9           /* "      "         "   "   "     "    */
if digs=='' | digs==","  then digs= 32           /* "      "         "   "   "     "    */
numeric digits digs + length(.)                  /*specify number of decimal digs to use*/
metals= 'platinum  golden  silver  bronze  copper  nickel  aluminum  iron  tin  lead'
@decDigs= ' decimal digits past the decimal point:'             /*a literal used in SAY.*/
!.=                                              /*the default name for a metallic ratio*/
         do k=0  to 9;  !.k= word(metals, k+1)   /*assign the (ten) metallic ratio names*/
         end   /*k*/

      do m=bLO   to bHI;  @.= 1;  $=  1  1       /*compute the sequence numbers & ratios*/
      r=.                                        /*the ratio  (so far).                 */
         do #=2  until r=old;     old= r         /*compute sequence numbers & the ratio.*/
                    #_1= #-1;       #_2= #-2     /*use variables for previous numbers.  */
         @.#= m * @.#_1     +     @.#_2          /*calculate a number i the sequence.   */
         if #<n  then $= $  @.#                  /*build a sequence list of  N  numbers.*/
         r= @.#  /  @.#_1                        /*calculate ratio of the last 2 numbers*/
         end   /*#*/

      if words($)<n  then $= subword($ copies('1 ', n), 1, n) /*extend list if too short*/
      L= max(108, length($) )                                 /*ensure width of title.  */
      say center(' Lucas sequence for the'  !.m  "ratio,  where  B  is " m' ',  L,  "═")
      if n>0  then do;   say 'the first '    n    " elements are:";       say $
                   end                           /*if  N  is positive, then show N nums.*/
      @approx= 'approximate'                     /*literal (1 word) that is used for SAY*/
      r= format(r,,digs)                         /*limit decimal digits for  R  to digs.*/
      if datatype(r, 'W')  then do;      r= r/1;      @approx=     "exact";       end
      say 'the'  @approx  "value reached after"   #-1   " iterations with "  digs @DecDigs
      say r;                    say              /*display the ration plus a blank line.*/
      end      /*m*/                             /*stick a fork in it,  we're all done. */


require('bigdecimal')
require('bigdecimal/util')

# An iterator over the Lucas Sequence for 'b'.
# (The special case of: x(n) = b * x(n-1) + x(n-2).)

def lucas(b)
  Enumerator.new do |yielder|
    xn2 = 1 ; yielder.yield(xn2)
    xn1 = 1 ; yielder.yield(xn1)
    loop { xn2, xn1 = xn1, b * xn1 + xn2 ; yielder.yield(xn1) }
  end
end

# Compute the Metallic Ratio to 'precision' from the Lucas Sequence for 'b'.
# (Uses the lucas(b) iterator, above.)
# The metallic ratio is approximated by x(n) / x(n-1).
# Returns a struct of the approximate metallic ratio (.ratio) and the
# number of terms required to achieve the given precision (.terms).

def metallic_ratio(b, precision)
  xn2 = xn1 = prev = this = 0
  lucas(b).each.with_index do |xn, inx|
    case inx
      when 0
        xn2 = BigDecimal(xn)
      when 1
        xn1 = BigDecimal(xn)
        prev = xn1.div(xn2, 2 * precision).round(precision)
      else
        xn2, xn1 = xn1, BigDecimal(xn)
        this = xn1.div(xn2, 2 * precision).round(precision)
        return Struct.new(:ratio, :terms).new(prev, inx - 1) if prev == this
        prev = this
    end
  end
end

NAMES = [ 'Platinum', 'Golden', 'Silver', 'Bronze', 'Copper',
          'Nickel', 'Aluminum', 'Iron', 'Tin', 'Lead' ]

puts
puts('Lucas Sequences...')
puts('%1s  %s' % ['b', 'sequence'])
(0..9).each do |b|
  puts('%1d  %s' % [b, lucas(b).first(15)])
end

puts
puts('Metallic Ratios to 32 places...')
puts('%-9s %1s %3s  %s' % ['name', 'b', 'n', 'ratio'])
(0..9).each do |b|
  rn = metallic_ratio(b, 32)
  puts('%-9s %1d %3d  %s' % [NAMES[b], b, rn.terms, rn.ratio.to_s('F')])
end

puts
puts('Golden Ratio to 256 places...')
puts('%-9s %1s %3s  %s' % ['name', 'b', 'n', 'ratio'])
gold_rn = metallic_ratio(1, 256)
puts('%-9s %1d %3d  %s' % [NAMES[1], 1, gold_rn.terms, gold_rn.ratio.to_s('F')])


metcon=: {{
  sleep=: 6!:3
  task=: {{
    11 T. lock               NB. wait
    sleep 2
    echo 'Task ',y,&":' has the semaphore'
    13 T. lock               NB. release
  }}
  lock=: 10 T. 0
  0&[email protected]'' each i.0>.4-1 T.'' NB. ensure at least four threads
  > task t.''"0 i.10         NB. dispatch and wait for 10 tasks
  14 T. lock                 NB. discard lock
}}


public class CountingSemaphore{
   private int lockCount = 0;
   private int maxCount;

   CountingSemaphore(int Max){
      maxCount = Max;
   }

   public synchronized void acquire() throws InterruptedException{
      while( lockCount >= maxCount){
         wait();
      }
      lockCount++;
   }
   public synchronized void release(){
      if (lockCount > 0)
      {
         lockCount--;
         notifyAll();
      }
   }
   public synchronized int getCount(){
      return lockCount;
   }
}

public class Worker extends Thread{
   private CountingSemaphore lock;
   private int id;

   Worker(CountingSemaphore coordinator, int num){
      lock = coordinator;
      id = num;
   }
   Worker(){
   }
   public void run(){
      try{
         lock.acquire();
         System.out.println("Worker " + id + " has acquired the lock.");
         sleep(2000);
      }
      catch (InterruptedException e){
      }
      finally{
         lock.release();
      }
   }
   public static void main(String[] args){
      CountingSemaphore lock = new CountingSemaphore(3);
      Worker crew[];
      crew = new Worker[5];
      for (int i = 0; i < 5; i++){
         crew[i] = new Worker(lock, i);
         crew[i].start();
      }

   }
}


function acquire(num, sem)
    sleep(rand())
    println("Task $num waiting for semaphore")
    lock(sem)
    println("Task $num has acquired semaphore")
    sleep(rand())
    unlock(sem)
end

function runsem(numtasks)
    println("Sleeping and running $numtasks tasks.")
    sem = Base.Threads.RecursiveSpinLock()
    @sync(
    for i in 1:numtasks
        @async acquire(i, sem)
    end)
    println("Done.")
end

runsem(4)


func seqRatio(f, places = 32) {
    1..Inf -> reduce {|t,n|
        var r = (f(n+1)/f(n)).round(-places)
        return(n, r.as_dec(places + r.abs.int.len)) if (r == t)
        r
    }
}

for k,v in (%w(Platinum Golden Silver Bronze Copper Nickel Aluminum Iron Tin Lead).kv) {
    next if (k == 0)   # undefined ratio
    say "Lucas sequence U_n(#{k},-1) for #{v} ratio"
    var f = {|n| lucasu(k, -1, n) }
    say ("First 15 elements: ", 15.of(f).join(', '))
    var (n, r) = seqRatio(f)
    say "Approximated value: #{r} reached after #{n} iterations"
    say ''
}

with (seqRatio({|n| fib(n) }, 256)) {|n,v|
    say "Golden ratio to 256 decimal places:"
    say "Approximated value: #{v}"
    say "Reached after #{n} iterations"
}


Imports BI = System.Numerics.BigInteger

Module Module1

    Function IntSqRoot(v As BI, res As BI) As BI
        REM res is the initial guess
        Dim term As BI = 0
        Dim d As BI = 0
        Dim dl As BI = 1
        While dl <> d
            term = v / res
            res = (res + term) >> 1
            dl = d
            d = term - res
        End While
        Return term
    End Function

    Function DoOne(b As Integer, digs As Integer) As String
        REM calculates result via square root, not iterations
        Dim s = b * b + 4
        digs += 1
        Dim g As BI = Math.Sqrt(s * Math.Pow(10, digs))
        Dim bs = IntSqRoot(s * BI.Parse("1" + New String("0", digs << 1)), g)
        bs += b * BI.Parse("1" + New String("0", digs))
        bs >>= 1
        bs += 4
        Dim st = bs.ToString
        digs -= 1
        Return String.Format("{0}.{1}", st(0), st.Substring(1, digs))
    End Function

    Function DivIt(a As BI, b As BI, digs As Integer) As String
        REM performs division
        Dim al = a.ToString.Length
        Dim bl = b.ToString.Length
        digs += 1
        a *= BI.Pow(10, digs << 1)
        b *= BI.Pow(10, digs)
        Dim s = (a / b + 5).ToString
        digs -= 1
        Return s(0) + "." + s.Substring(1, digs)
    End Function

    REM custom formatting
    Function Joined(x() As BI) As String
        Dim wids() = {1, 1, 2, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13}
        Dim res = ""
        For i = 0 To x.Length - 1
            res += String.Format("{0," + (-wids(i)).ToString + "} ", x(i))
        Next
        Return res
    End Function

    Sub Main()
        REM calculates and checks each "metal"
        Console.WriteLine("Metal B Sq.Rt Iters /---- 32 decimal place value ----\\  Matches Sq.Rt Calc")
        Dim t = ""
        Dim n As BI
        Dim nm1 As BI
        Dim k As Integer
        Dim j As Integer
        For b = 0 To 9
            Dim lst(14) As BI
            lst(0) = 1
            lst(1) = 1
            For i = 2 To 14
                lst(i) = b * lst(i - 1) + lst(i - 2)
            Next
            REM since all the iterations (except Pt) are > 15, continue iterating from the end of the list of 15
            n = lst(14)
            nm1 = lst(13)
            k = 0
            j = 13
            While k = 0
                Dim lt = t
                t = DivIt(n, nm1, 32)
                If lt = t Then
                    k = If(b = 0, 1, j)
                End If
                Dim onn = n
                n = b * n + nm1
                nm1 = onn

                j += 1
            End While
            Console.WriteLine("{0,4}  {1}   {2,2}    {3, 2}  {4}  {5}" + vbNewLine + "{6,19} {7}", "Pt Au Ag CuSn Cu Ni Al Fe Sn Pb".Split(" ")(b), b, b * b + 4, k, t, t = DoOne(b, 32), "", Joined(lst))
        Next
        REM now calculate and check big one
        n = 1
        nm1 = 1
        k = 0
        j = 1
        While k = 0
            Dim lt = t
            t = DivIt(n, nm1, 256)
            If lt = t Then
                k = j
            End If
            Dim onn = n
            n += nm1
            nm1 = onn

            j += 1
        End While
        Console.WriteLine()
        Console.WriteLine("Au to 256 digits:")
        Console.WriteLine(t)
        Console.WriteLine("Iteration count: {0}  Matched Sq.Rt Calc: {1}", k, t = DoOne(1, 256))
    End Sub

End Module


// version 1.1.51

import java.util.concurrent.Semaphore
import kotlin.concurrent.thread

fun main(args: Array<String>) {
    val numPermits = 4
    val numThreads = 9
    val semaphore = Semaphore(numPermits)
    for (i in 1..numThreads) {
        thread {
            val name = "Unit #$i"
            semaphore.acquire()
            println("$name has acquired the semaphore")
            Thread.sleep(2000)
            semaphore.release()
            println("$name has released the semaphore")
        }
    }
}


:- object(metered_concurrency).

    :- threaded.

    :- public(run/2).
    run(Workers, Max) :-
        % start the semaphore and the workers
        threaded_ignore(semaphore(Max, Max)),
        forall(
            integer::between(1, Workers, Worker),
            threaded_call(worker(Worker))
        ),
        % wait for the workers to finish
        forall(
            integer::between(1, Workers, Worker),
            threaded_exit(worker(Worker))
        ),
        % tell the semaphore thread to stop
        threaded_notify(worker(stop, _)).

    :- public(run/0).
    run :-
        % default values: 7 workers, 2 concurrent workers
        run(7, 2).

    semaphore(N, Max) :-
        threaded_wait(worker(Action, Worker)),
        (   Action == acquire, N > 0 ->
            M is N - 1,
            threaded_notify(semaphore(acquired, Worker)),
            semaphore(M, Max)
        ;   Action == release ->
            M is N + 1,
            threaded_notify(semaphore(released, Worker)),
            semaphore(M, Max)
        ;   Action == stop ->
            true
        ;   % Action == acquire, N =:= 0,
            threaded_wait(worker(release, OtherWorker)),
            threaded_notify(semaphore(released, OtherWorker)),
            threaded_notify(semaphore(acquired, Worker)),
            semaphore(N, Max)
        ).

    worker(Worker) :-
        % use a random setup time for the worker
        random::random(0.0, 2.0, Setup),
        thread_sleep(Setup),
        threaded_notify(worker(acquire, Worker)),
        threaded_wait(semaphore(acquired, Worker)),
        write('Worker '), write(Worker), write(' acquired semaphore\n'),
        thread_sleep(2),
        threaded_notify(worker(release, Worker)),
        write('Worker '), write(Worker), write(' releasing semaphore\n'),
        threaded_wait(semaphore(released, Worker)).

:- end_object.


import os, posix, strformat

type SemaphoreError = object of CatchableError

var
  sem: Sem
  running = true

proc init(sem: var Sem; count: Natural) =
  if sem_init(sem.addr, 0, count.cint) != 0:
    raise newException(SemaphoreError, "unable to initialize semaphore")

proc count(sem: var Sem): int =
  var c: cint
  if sem_getvalue(sem.addr, c) != 0:
    raise newException(SemaphoreError, "unable to get value of semaphore")
  result = c

proc acquire(sem: var Sem) =
  if sem_wait(sem.addr) != 0:
    raise newException(SemaphoreError, "unable to acquire semaphore")

proc release(sem: var Sem) =
  if sem_post(sem.addr) != 0:
    raise newException(SemaphoreError, "unable to get release semaphore")

proc close(sem: var Sem) =
  if sem_destroy(sem.addr) != 0:
    raise newException(SemaphoreError, "unable to close the semaphore")

proc task(id: int) {.thread.} =
  echo &"Task {id} started."
  while running:
    sem.acquire()
    echo &"Task {id} acquired semaphore. Count is {sem.count()}."
    sleep(2000)
    sem.release()
    echo &"Task {id} released semaphore. Count is {sem.count()}."
    sleep(100)    # Give time to other tasks.
  echo &"Task {id} terminated."

proc stop() {.noconv.} = running = false

var threads: array[10, Thread[int]]

sem.init(4)
setControlCHook(stop)   # Catch control-C to terminate gracefully.

for n in 0..9: createThread(threads[n], task, n)
threads.joinThreads()
sem.close()


import "/big" for BigInt, BigRat
import "/fmt" for Fmt

var names = ["Platinum", "Golden", "Silver", "Bronze", "Copper","Nickel", "Aluminium", "Iron", "Tin", "Lead"]

var lucas = Fn.new { |b|
    Fmt.print("Lucas sequence for $s ratio, where b = $d:", names[b], b)
    System.write("First 15 elements: ")
    var x0 = 1
    var x1 = 1
    Fmt.write("$d, $d", x0, x1)
    for (i in 1..13) {
        var x2 = b*x1 + x0
        Fmt.write(", $d", x2)
        x0 = x1
        x1 = x2
    }
    System.print()
}

var metallic = Fn.new { |b, dp|
    var x0 = BigInt.one
    var x1 = BigInt.one
    var x2 = BigInt.zero
    var bb = BigInt.new(b)
    var ratio = BigRat.new(BigInt.one, BigInt.one)
    var iters = 0
    var prev = ratio.toDecimal(dp)
    while (true) {
        iters = iters + 1
        x2 = bb*x1 + x0
        ratio = BigRat.new(x2, x1)
        var curr = ratio.toDecimal(dp)
        if (prev == curr) {
            var plural = (iters == 1) ? " " : "s"
            Fmt.print("Value to $d dp after $2d iteration$s: $s\n", dp, iters, plural, curr)
            return
        }
        prev = curr
        x0 = x1
        x1 = x2
    }
}

for (b in 0..9) {
    lucas.call(b)
    metallic.call(b, 32)
}
System.print("Golden ratio, where b = 1:")
metallic.call(1, 256)


var [const] BI=Import("zklBigNum");  // libGMP
fcn lucasSeq(b){
   Walker.zero().tweak('wrap(xs){
      xm2,xm1 := xs;	// x[n-2], x[n-1]
      xn:=xm1*b + xm2;
      xs.append(xn).del(0);
      xn
   }.fp(L(BI(1),BI(1)))).push(1,1)  // xn can get big so use BigInts
}
fcn metallicRatio(lucasSeq,digits=32,roundup=True){ #-->(String,num iterations)
   bige:=BI("1e"+(digits+1));  # x[n-1]*bige*b / x[n-2] to get our digits from Ints
   a,b,mr := lucasSeq.next(), lucasSeq.next(), (bige*b).div(a);
   do(20_000){	// limit iterations
      c,mr2 := lucasSeq.next(), (bige*c).div(b);
      if(mr==mr2){
	 mr=mr2.add(5*roundup).div(10).toString();
	 return(String(mr[0],".",mr.del(0)),
	    lucasSeq.idx); // idx ignores push(), ie first 2 terms
      }
      b,mr = c,mr2;
   }
}


import: parallel

Object Class new: Semaphore(ch)

Semaphore method: initialize(n)
   Channel newSize(n) dup := ch
   #[ 1 over send drop ] times(n) drop ;

Semaphore method: acquire  @ch receive drop ;
Semaphore method: release  1 @ch send drop ;


declare
  fun {NewSemaphore N}
     sem(max:N count:{NewCell 0} 'lock':{NewLock} sync:{NewCell _})
  end

  proc {Acquire Sem=sem(max:N count:C 'lock':L sync:S)}
     Sync
     Acquired
  in
     lock L then
        if @C < N then
         C := @C + 1
         Acquired = true
        else
         Sync = @S
         Acquired = false
        end
     end
     if {Not Acquired} then
        {Wait Sync}
        {Acquire Sem}
     end
  end

  proc {Release sem(count:C 'lock':L sync:S ...)}
     lock L then
        C := @C - 1
        @S = unit %% wake up waiting threads
        S := _ %% prepare for new waiters
     end
  end

  proc {WithSemaphore Sem Proc}
     {Acquire Sem}
     try
        {Proc}
     finally
        {Release Sem}
     end
  end

  S = {NewSemaphore 4}

  proc {StartWorker Name}
     thread
	for do
	   {WithSemaphore S
	    proc {$}
	       {System.showInfo Name#" acquired semaphore"}
	       {Delay 2000}
	    end
	   }
	   {Delay 100}
	end
     end
  end
in
  for I in 1..10 do
     {StartWorker I}
  end


without js -- (tasks)
sequence sems = {}
constant COUNTER = 1, QUEUE = 2

function semaphore(integer n)
    if n>0 then
        sems = append(sems,{n,{}})
        return length(sems)
    else
        return 0
    end if
end function

procedure acquire(integer id)
    if sems[id][COUNTER]=0 then
        task_suspend(task_self())
        sems[id][QUEUE] &= task_self()
        task_yield()
    end if
    sems[id][COUNTER] -= 1
end procedure

procedure release(integer id)
    sems[id][COUNTER] += 1
    if length(sems[id][QUEUE])>0 then
        task_schedule(sems[id][QUEUE][1],1)
        sems[id][QUEUE] = sems[id][QUEUE][2..$]
    end if
end procedure

function count(integer id)
    return sems[id][COUNTER]
end function

procedure delay(atom delaytime)
    atom t = time()
    while time()-t<delaytime do
        task_yield()
    end while
end procedure

integer sem = semaphore(4)

procedure worker()
    acquire(sem)
    printf(1,"- Task %d acquired semaphore.\n",task_self())
    delay(2)
    release(sem)
    printf(1,"+ Task %d released semaphore.\n",task_self())
end procedure

for i=1 to 10 do
    integer task = task_create(routine_id("worker"),{})
    task_schedule(task,1)
    task_yield()
end for

integer sc = 0
atom t0 = time()+1
while length(task_list())>1 do
    task_yield()
    integer scnew = count(sem)
    if scnew!=sc
    or time()>t0 then
        sc = scnew
        printf(1,"Semaphore count now %d\n",{sc})
        t0 = time()+2
    end if
end while
?"done"
{} = wait_key()


(let Sem (tmp "sem")
   (for U 4  # Create 4 concurrent units
      (unless (fork)
         (ctl Sem
            (prinl "Unit " U " aquired the semaphore")
            (wait 2000)
            (prinl "Unit " U " releasing the semaphore") )
         (bye) ) ) )


#Threads=10
#Parallels=3
Global Semaphore=CreateSemaphore(#Parallels)

Procedure Worker(*arg.i)
  WaitSemaphore(Semaphore)
  Debug "Thread #"+Str(*arg)+" active."
  Delay(Random(2000))
  SignalSemaphore(Semaphore)
EndProcedure

; Start a multi-thread based work
Dim thread(#Threads)
For i=0 To #Threads
  thread(i)=CreateThread(@Worker(),i)
Next
Debug "Launcher done."

; Wait for all threads to finish before closing down
For i=0 To #Threads
  If IsThread(i)
    WaitThread(i)
  EndIf
Next


import time
import threading

# Only 4 workers can run in the same time
sem = threading.Semaphore(4)

workers = []
running = 1

def worker():
    me = threading.currentThread()
    while 1:
        sem.acquire()
        try:
            if not running:
                break
            print '%s acquired semaphore' % me.getName()
            time.sleep(2.0)
        finally:
            sem.release()
        time.sleep(0.01) # Let others acquire

# Start 10 workers
for i in range(10):
    t = threading.Thread(name=str(i), target=worker)
    workers.append(t)
    t.start()

# Main loop
try:
    while 1:
        time.sleep(0.1)
except KeyboardInterrupt:
    running = 0
    for t in workers:
        t.join()


#lang racket

(define sema (make-semaphore 4)) ; allow 4 concurrent jobs

;; start 20 jobs and wait for all of them to end
(for-each
 thread-wait
 (for/list ([i 20])
   (thread (λ() (semaphore-wait sema)
                (printf "Job #~a acquired semaphore\n" i)
                (sleep 2)
                (printf "Job #~a done\n" i)
                (semaphore-post sema)))))


class Semaphore {
    has $.tickets = Channel.new;
    method new ($max) {
        my $s = self.bless;
        $s.tickets.send(True) xx $max;
        $s;
    }
    method acquire { $.tickets.receive }
    method release { $.tickets.send(True) }
}

sub MAIN ($units = 5, $max = 2) {
    my $sem = Semaphore.new($max);

    my @units = do for ^$units -> $u {
        start {
            $sem.acquire; say "unit $u acquired";
            sleep 2;
            $sem.release; say "unit $u released";
        }
    }
    await @units;
}


# four workers may be concurrent
4 semaphore as sem

thread worker
    5 each as i
        sem acquire
        # tid is thread id
        tid "%d acquired semaphore\n" print
        2000 ms
        sem release
        # let others acquire
        100 ms

# start 10 threads
group
    10 each drop worker
list as workers


require 'thread'

# Simple Semaphore implementation
class Semaphore
  def initialize(size = 1)
    @queue = SizedQueue.new(size)
    size.times { acquire }
  end

  def acquire
    tap { @queue.push(nil) }
  end

  def release
    tap { @queue.pop }
  end

  # @return [Integer]
  def count
    @queue.length
  end

  def synchronize
    release
    yield
  ensure
    acquire
  end
end

def foo(id, sem)
  sem.synchronize do
    puts "Thread #{id} Acquired lock"
    sleep(2)
  end
end

threads = []
n = 5
s = Semaphore.new(3)
n.times do |i|
  threads << Thread.new { foo i, s }
end
threads.each(&:join)


//! Rust has a perfectly good Semaphore type already. It lacks count(), though, so we can't use it
//! directly.

use std::sync::atomic::AtomicUsize;
use std::sync::atomic::Ordering::SeqCst;
use std::sync::mpsc::channel;
use std::sync::Arc;
use std::thread::{self, spawn};
use std::time::Duration;

pub struct CountingSemaphore {
    /// Remaining resource count
    count: AtomicUsize,

    /// How long to sleep if a resource is being contended
    backoff: Duration,
}

pub struct CountingSemaphoreGuard<'a> {
    /// A reference to the owning semaphore.
    sem: &'a CountingSemaphore,
}

impl CountingSemaphore {
    /// Create a semaphore with `max` available resources and a linearly increasing backoff of
    /// `backoff` (used during spinlock contention).
    pub fn new(max: usize, backoff: Duration) -> CountingSemaphore {
        CountingSemaphore {
            count: AtomicUsize::new(max),
            backoff,
        }
    }

    /// Acquire a resource, returning a RAII CountingSemaphoreGuard.
    pub fn acquire(&self) -> CountingSemaphoreGuard {
        // Spinlock until remaining resource count is at least 1
        let mut backoff = self.backoff;
        loop {
            // Probably don't need SeqCst here, but it doesn't hurt.
            let count = self.count.load(SeqCst);
            // The check for 0 is necessary to make sure we don't go negative, which is why this
            // must be a compare-and-swap rather than a straight decrement.
            if count == 0
                || self
                    .count
                    .compare_exchange(count, count - 1, SeqCst, SeqCst)
                    .is_err()
            {
                // Linear backoff a la Servo's spinlock contention.
                thread::sleep(backoff);
                backoff += self.backoff;
            } else {
                // We successfully acquired the resource.
                break;
            }
        }
        CountingSemaphoreGuard { sem: self }
    }

    // Return remaining resource count
    pub fn count(&self) -> usize {
        self.count.load(SeqCst)
    }
}

impl<'a> Drop for CountingSemaphoreGuard<'a> {
    /// When the guard is dropped, a resource is released back to the pool.
    fn drop(&mut self) {
        self.sem.count.fetch_add(1, SeqCst);
    }
}

fn metered(duration: Duration) {
    static MAX_COUNT: usize = 4; // Total available resources
    static NUM_WORKERS: u8 = 10; // Number of workers contending for the resources
    let backoff = Duration::from_millis(1); // Linear backoff time
                                            // Create a shared reference to the semaphore
    let sem = Arc::new(CountingSemaphore::new(MAX_COUNT, backoff));
    // Create a channel for notifying the main task that the workers are done
    let (tx, rx) = channel();
    for i in 0..NUM_WORKERS {
        let sem = Arc::clone(&sem);
        let tx = tx.clone();
        spawn(move || {
            // Acquire the resource
            let guard = sem.acquire();
            let count = sem.count();
            // Make sure the count is legal
            assert!(count < MAX_COUNT);
            println!("Worker {} after acquire: count = {}", i, count);
            // Sleep for `duration`
            thread::sleep(duration);
            // Release the resource
            drop(guard);
            // Make sure the count is legal
            let count = sem.count();
            assert!(count <= MAX_COUNT);
            println!("Worker {} after release: count = {}", i, count);
            // Notify the main task of completion
            tx.send(()).unwrap();
        });
    }
    drop(tx);
    // Wait for all the subtasks to finish
    for _ in 0..NUM_WORKERS {
        rx.recv().unwrap();
    }
}

fn main() {
    // Hold each resource for 2 seconds per worker
    metered(Duration::from_secs(2));
}


class CountingSemaphore(var maxCount: Int) {
  private var lockCount = 0

  def acquire(): Unit = {
    while ( {
      lockCount >= maxCount
    }) wait()
    lockCount += 1
  }

  def release(): Unit = {
    if (lockCount > 0) {
      lockCount -= 1
      notifyAll()
    }
  }

  def getCount: Int = lockCount
}

object Worker {
  def main(args: Array[String]): Unit = {
    val (lock, crew) = (new CountingSemaphore(3), new Array[Worker](5))

    for { i <- 0 until 5} {
      crew(i) = new Worker(lock, i)
      crew(i).start()
    }
  }
}


package require Tcl 8.6
package require Thread

# Create the global shared state of the semaphore
set handle semaphore0
tsv::set $handle mutex [thread::mutex create]
tsv::set $handle cv [thread::cond create]
tsv::set $handle count 0
tsv::set $handle max 3

# Make five worker tasks
for {set i 0} {$i<5} {incr i} {
    lappend threads [thread::create -preserved {
	# Not bothering to wrap this in an object for demonstration
	proc init {handle} {
	    global mutex cv count max
	    set mutex [tsv::object $handle mutex]
	    set cv [tsv::object $handle cv]
	    set count [tsv::object $handle count]
	    set max [tsv::get $handle max]
	}
	proc acquire {} {
	    global mutex cv count max
	    thread::mutex lock [$mutex get]
	    while {[$count get] >= $max} {
		thread::cond wait [$cv get] [$mutex get]
	    }
	    $count incr
	    thread::mutex unlock [$mutex get]
	}
	proc release {} {
	    global mutex cv count max
	    thread::mutex lock [$mutex get]
	    if {[$count get] > 0} {
		$count incr -1
		thread::cond notify [$cv get]
	    }
	    thread::mutex unlock [$mutex get]
	}

        # The core task of the worker
	proc run {handle id} {
	    init $handle
	    acquire
	    puts "worker $id has acquired the lock"
	    after 2000
	    release
	    puts "worker $id is done"
	}

        # Wait for further instructions from the main thread
	thread::wait
    }]
}

# Start the workers doing useful work, giving each a unique id for pretty printing
set i 0
foreach t $threads {
    puts "starting thread [incr i]"
    thread::send -async $t [list run $handle $i]
}

# Wait for all the workers to finish
foreach t $threads {
    thread::release -wait $t
}


rm -f sem ; mkfifo sem

acquire() {
   x='';while test -z "$x"; do read x; done;
}

release() {
   echo '1'
}

job() {
   n=$1; echo "Job $n acquired Semaphore">&2 ; sleep 2; echo "Job $n released Semaphore">&2 ;
}

( acquire < sem ; job 1 ; release > sem ) &
( acquire < sem ; job 2 ; release > sem ) &
( acquire < sem ; job 3 ; release > sem ) &

echo 'Initialize Jobs' >&2 ; echo '1' > sem


Dim sem As New Semaphore(5, 5) 'Indicates that up to 5 resources can be aquired
sem.WaitOne() 'Blocks until a resouce can be aquired
Dim oldCount = sem.Release() 'Returns a resource to the pool
'oldCount has the Semaphore's count before Release was called


import "scheduler" for Scheduler
import "timer" for Timer
import "/queue" for Queue

class CountingSemaphore {
    construct new(numRes) {
        _count = numRes
        _queue = Queue.new()
    }

    count { _count }

    acquire(task) {
        if (_count > 0) {
            _count = _count - 1
            return true
        }
        _queue.push(task)
        return false
    }

    release() {
        if (!_queue.isEmpty) {
            var task = _queue.pop()
            task.transfer()
        } else {
            _count = _count + 1
        }
    }
}

var numRes   = 3
var numTasks = 6
var tasks = List.filled(6, null)
var cs = CountingSemaphore.new(numRes)
var main = Fiber.current

var duty = Fn.new { |n|
    System.print("Task %(n) started when count = %(cs.count).")
    var acquired = cs.acquire(Fiber.current)
    if (!acquired) {
        System.print("Task %(n) waiting for semaphore.")
        Fiber.yield() // return to calling fiber in the meantime
    }
    System.print("Task %(n) has acquired the semaphore.")
    Scheduler.add {
        // whilst this fiber is sleeping, start the next task if there is one
        var next = n + 1
        if (next <= numTasks) {
            tasks[next-1].call(next)
        }
    }
    Timer.sleep(2000)
    System.print("Task %(n) has released the semaphore.")
    cs.release()
    if (n == numTasks) main.transfer() // on completion of last task, return to main fiber
}

// create fibers for tasks
for (i in 0..5) tasks[i] = Fiber.new(duty)

// call the first one
tasks[0].call(1)
System.print("\nAll %(numTasks) tasks completed!")


fcn job(name,sem){
   name.println(" wait"); sem.acquire();
   name.println(" go"); Atomic.sleep(2);
   sem.release(); name.println(" done")
}
   // start 3 threads using the same semphore
s:=Thread.Semaphore(1);
job.launch("1",s); job.launch("2",s); job.launch("3",s);


# This example uses ALGOL 68 user defined operators to add a COBOL-style     #
# "INSPECT statement" to ALGOL 68                                            #
#                                                                            #
# The (partial) syntax of the COBOL INSPECT is:                              #
#    INSPECT string-variable REPLACING ALL     string BY string              #
# or INSPECT string-variable REPLACING LEADING string BY string              #
# or INSPECT string-variable REPLACING FIRST   string BY string              #
#                                                                            #
# Because "BY" is a reserved bold word in ALGOL 68, we use "WITH" instead    #
#                                                                            #
# We define unary  operators INSPECT, ALL, LEADING and FIRST                 #
#       and binary operators REPLACING and WITH                              #
# We choose the priorities of REPLACING and WITH so that parenthesis is not  #
# needed to ensure the correct interpretation of the "statement"             #
#                                                                            #
# We also provide a unary DISPLAY operator for a partial COBOL DISPLAY       #
# statement                                                                  #

# INSPECTEE is returned by the INSPECT unary operator                        #
MODE INSPECTEE   = STRUCT( REF STRING item, INT option );

# INSPECTTOREPLACE is returned by the binary REPLACING operator              #
MODE INSPECTTOREPLACE
                 = STRUCT( REF STRING item, INT option, STRING to replace );
# REPLACEMENT is returned by the unary ALL, LEADING and FIRST operators      #
MODE REPLACEMENT = STRUCT( INT option, STRING replace );

# REPLACING option codes, these are the option values for a REPLACEMENT      #
INT  replace all     = 1;
INT  replace leading = 2;
INT  replace first   = 3;

OP   INSPECT   = ( REF STRING s )INSPECTEE: ( s, 0 );
OP   ALL       = ( STRING replace )REPLACEMENT: ( replace all,     replace );
OP   LEADING   = ( STRING replace )REPLACEMENT: ( replace leading, replace );
OP   FIRST     = ( STRING replace )REPLACEMENT: ( replace first,   replace );
OP   ALL       = ( CHAR   replace )REPLACEMENT: ( replace all,     replace );
OP   LEADING   = ( CHAR   replace )REPLACEMENT: ( replace leading, replace );
OP   FIRST     = ( CHAR   replace )REPLACEMENT: ( replace first,   replace );

OP   REPLACING = ( INSPECTEE inspected, REPLACEMENT replace )INSPECTTOREPLACE:
                     ( item    OF inspected
                     , option  OF replace
                     , replace OF replace
                     );

OP   WITH      = ( INSPECTTOREPLACE inspected, CHAR   replace with )REF STRING:
    BEGIN
        STRING with := replace with;
        inspected WITH with
    END; # WITH #

OP   WITH      = ( INSPECTTOREPLACE inspected, STRING replace with )REF STRING:
    BEGIN

        STRING    to replace  = to replace OF inspected;
        INT       pos        := 0;
        STRING    rest       := item OF inspected;
        STRING    result     := "";

        IF   option OF inspected = replace all
        THEN
            # replace all occurances of "to replace" with "replace with"     #
            WHILE string in string( to replace, pos, rest )
            DO
                result +:= rest[ 1 : pos - 1 ] + replace with;
                rest    := rest[ pos + UPB to replace : ]
            OD

        ELIF option OF inspected = replace leading
        THEN
            # replace leading occurances of "to replace" with "replace with" #
            WHILE IF string in string( to replace, pos, rest )
                  THEN
                      pos = 1
                  ELSE
                      FALSE
                  FI
            DO
                result +:= replace with;
                rest    := rest[ 1 + UPB to replace : ]
            OD

        ELIF option OF inspected = replace first
        THEN
            # replace first occurance of "to replace" with "replace with"    #
            IF string in string( to replace, pos, rest )
            THEN
                result +:= rest[ 1 : pos - 1 ] + replace with;
                rest    := rest[ pos + UPB to replace : ]
            FI

        ELSE
            # unsupported replace option #
            write( ( newline, "*** unsupported INSPECT REPLACING...", newline ) );
            stop
        FI;

        result +:= rest;
        item OF inspected := result
    END; # WITH #

OP   DISPLAY = ( STRING s )VOID: write( ( s, newline ) );

PRIO REPLACING = 2, WITH = 1;

main: (

    # test the INSPECT and DISPLAY "verbs" #

    STRING  text := "some text";
    DISPLAY text;

    INSPECT text REPLACING FIRST   "e"    WITH "bbc";
    DISPLAY text;

    INSPECT text REPLACING ALL     "b"    WITH "X";
    DISPLAY text;

    INSPECT text REPLACING ALL     "text" WITH "some";
    DISPLAY text;

    INSPECT text REPLACING LEADING "som"  WITH "k";
    DISPLAY text

)


sumThemUp: function [x,y][
    x+y
]

alias.infix '--> 'sumThemUp

do [
    print 3 --> 4
]


// http://stackoverflow.com/questions/3385515/static-assert-in-c
#define STATIC_ASSERT(COND,MSG) typedef char static_assertion_##MSG[(!!(COND))*2-1]
// token pasting madness:
#define COMPILE_TIME_ASSERT3(X,L) STATIC_ASSERT(X,static_assertion_at_line_##L)
#define COMPILE_TIME_ASSERT2(X,L) COMPILE_TIME_ASSERT3(X,L)
#define COMPILE_TIME_ASSERT(X)    COMPILE_TIME_ASSERT2(X,__LINE__)

COMPILE_TIME_ASSERT(sizeof(long)==8);
int main()
{
    COMPILE_TIME_ASSERT(sizeof(int)==4);
}


(loop for count from 1
      for x in '(1 2 3 4 5)
      summing x into sum
      summing (* x x) into sum-of-squares
      finally
        (return
          (let* ((mean (/ sum count))
                 (spl-var (- (* count sum-of-squares) (* sum sum)))
                 (spl-dev (sqrt (/ spl-var (1- count)))))
            (values mean spl-var spl-dev))))


enum GenStruct(string name, string fieldName) =
    "struct " ~ name ~ "{ int " ~ fieldName ~ "; }";

// Equivalent to:  struct Foo { int bar; }
mixin(GenStruct!("Foo", "bar"));

void main() {
    Foo f;
    f.bar = 10;
}


\ BRANCH and LOOP COMPILERS

\ branch offset computation operators
: AHEAD    ( -- addr)  HERE   0 , ;
: BACK     ( addr -- ) HERE   - , ;
: RESOLVE  ( addr -- ) HERE OVER - SWAP ! ;

\ LEAVE stack is called L0. It is initialized by QUIT.
: >L        ( x -- ) ( L: -- x )  2 LP +!  LP @ ! ;
: L>        ( -- x )  ( L: x -- ) LP @ @   -2 LP +! ;

\ finite loop compilers
: DO        ( -- ) POSTPONE <DO>     HERE 0 >L   3 ;  IMMEDIATE
: ?DO       ( -- ) POSTPONE <?DO>    HERE 0 >L   3 ;  IMMEDIATE
: LEAVE     ( -- ) ( L: -- addr )
            POSTPONE UNLOOP   POSTPONE BRANCH AHEAD >L ; IMMEDIATE

: RAKE      ( -- ) ( L: 0 a1 a2 .. aN -- )
            BEGIN  L> ?DUP WHILE  RESOLVE  REPEAT ;   IMMEDIATE

: LOOP      ( -- )  3 ?PAIRS POSTPONE <LOOP>  BACK  RAKE ; IMMEDIATE
: +LOOP     ( -- )  3 ?PAIRS POSTPONE <+LOOP> BACK  RAKE ; IMMEDIATE

\ conditional branches
: IF          ( ? -- ) POSTPONE ?BRANCH AHEAD 2 ;        IMMEDIATE
: THEN        ( -- )  ?COMP  2 ?PAIRS RESOLVE ;          IMMEDIATE
: ELSE        ( -- )  2 ?PAIRS  POSTPONE BRANCH AHEAD SWAP 2
                      POSTPONE THEN 2 ;                  IMMEDIATE

\ infinite loop compilers
: BEGIN       ( -- addr n) ?COMP HERE  1  ;              IMMEDIATE
: AGAIN       ( -- )   1 ?PAIRS POSTPONE BRANCH BACK   ;  IMMEDIATE
: UNTIL       ( ? -- ) 1 ?PAIRS POSTPONE ?BRANCH BACK  ;  IMMEDIATE
: WHILE       ( ? -- ) POSTPONE IF  2+  ;                IMMEDIATE
: REPEAT      ( -- )   2>R POSTPONE AGAIN  2R> 2- POSTPONE THEN ; IMMEDIATE


' FB 1.05.0 Win64

#Macro ForAll(C, S)
For _i as integer = 0 To Len(s)
#Define C (Chr(s[_i]))
#EndMacro

#Define In ,

Dim s As String = "Rosetta"
ForAll(c in s)
  Print c; " ";
Next

Print
Sleep


package main

import "fmt"

type person struct{
    name string
    age int
}

func copy(p person) person {
    return person{p.name, p.age}
}

func main() {
    p := person{"Dave", 40}
    fmt.Println(p)
    q := copy(p)
    fmt.Println(q)
    /*
    is := []int{1, 2, 3}
    it := make([]int, 3)
    copy(it, is)
    */
}


macro dowhile(condition, block)
    quote
        while true
            $(esc(block))
            if !$(esc(condition))
                break
            end
        end
    end
end

macro dountil(condition, block)
    quote
        while true
            $(esc(block))
            if $(esc(condition))
                break
            end
        end
    end
end

using Primes

arr = [7, 31]

@dowhile (!isprime(arr[1]) && !isprime(arr[2])) begin
    println(arr)
    arr .+= 1
end
println("Done.")

@dountil (isprime(arr[1]) || isprime(arr[2])) begin
    println(arr)
    arr .+= 1
end
println("Done.")


// version 1.0.6

infix fun Double.pwr(exp: Double) = Math.pow(this, exp)

fun main(args: Array<String>) {
   val d = 2.0 pwr 8.0
   println(d)
}


r = RETURN
str = "on halt"&r&"--do nothing"&r&"end"
new(#script).scripttext = str


Module Meta {
      FunName$="Alfa"
      Code1$=FunName$+"=lambda (X)->{"
      Code2$={
            =x**2
      }
      Code3$="}"

      Inline code1$+code2$+code3$

      Print Function(FunName$, 4)=16

}
Meta


CircleTimes[x_, y_] := Mod[x, 10] Mod[y, 10]
14\[CircleTimes]13


proc `^`*[T: SomeInteger](base, exp: T): T =
  var (base, exp) = (base, exp)
  result = 1

  while exp != 0:
    if (exp and 1) != 0:
      result *= base
    exp = exp shr 1
    base *= base

echo 2 ^ 10 # 1024


(define-syntax define
   (syntax-rules (lambda) ;λ
      ((define ((name . args) . more) . body)
         (define (name . args) (lambda more . body)))
      ((define (name . args) . body)
         (setq name (letq (name) ((lambda args . body)) name)))
      ((define name (lambda (var ...) . body))
         (setq name (letq (name) ((lambda (var ...) . body)) name)))
      ((define name val)
         (setq name val))
      ((define name a b . c)
         (define name (begin a b . c)))))


'EQUATES

% half 0.5
$ title "My Metaprogram"

'CONDITIONAL BLOCKS

 #ifdef ...
   ...
 #elseif ...
   ...
 #else
   ...
 #endif

'MACROS

'msdos-like
def sum
  %1 + %2
end def

'C-like
#define sum(a,b) a + b

'native
macro sum(a,b)
  a + b
end macro

'native macro functions
macro sum int(r,a,b)
  r = a + b
end macro


Function: [email protected]_
Help: [email protected]: compute the lesser of x and y, or 0, whichever is larger.
Section: symbolic_operators
C-Name: gmin0
Prototype: GG
Description:
 (small, small):small	 smin0ss($1, $2)
 (mp, mp):mp            gmin0($1, $2)
 (gen, gen):gen     	 gmin0($1, $2)


package UnicodeEllipsis;

use Filter::Simple;

FILTER_ONLY code => sub { s/…/../g };


object x
#isginfo{x,0b0101,5,7,integer,3}
--    {var,type,min,max,etype,len}
    -- (0b0101 is dword sequence|integer)
    x = {1,2,3} -- sequence of integer, length 3
    x = 5       -- integer 5 (becomes min)
    x = 7       -- integer 7 (becomes max)


/ift {
4 dict begin
    [/.if /.then] let*
    count array astore /.stack exch def
    /_restore {clear .stack aload pop}.
    .stack aload pop .if {
       _restore .then
    } {
       _restore
    } ifelse
end}.


:- initialization(main).
main :- clause(less_than(1,2),B),writeln(B).
less_than(A,B) :- A<B.


from macropy.core.macros import *
from macropy.core.quotes import macros, q, ast, u

macros = Macros()

@macros.expr
def expand(tree, **kw):
    addition = 10
    return q[lambda x: x * ast[tree] + u[addition]]


( +---------------------------------------------------+ )
( | add inline comments ";" to Quackery with "builds" | )
( +---------------------------------------------------+ )

[ dup $ "" = not while
  behead carriage =
  until ]            builds ;             ( [ $ --> [ $ )

; +---------------------------------------------------+
; |  add switch to Quackery with ]else[ ]'[ & ]done[  |
; +---------------------------------------------------+

[ stack ]                is switch.arg    (     --> s   )
protect switch.arg

[ switch.arg put ]       is switch        (   x -->     )

[ switch.arg release ]   is otherwise

[ switch.arg share
  != iff ]else[ done
  otherwise
  ]'[ do ]done[ ]        is case          (   x -->     )

[ switch
  1       case [ say "The number 1."     cr ]
  $ "two" case [ say 'The string "two".' cr ]
     otherwise [ say "Something else."   cr ] ] is test
                                          (   x -->     )

' tally test     ; output should be: Something else.
$ "two" test     ; output should be: The string "two".
      1 test     ; output should be: The number 1.


'%C%' <- function(n, k) choose(n, k)
5 %C% 2 #Outputs 10.


#lang racket

(define-syntax-rule (list-when test body)
  (if test
      body
      '()))

(let ([not-a-string 42])
  (list-when (string? not-a-string)
    (string->list not-a-string)))


extend ViewParseTree;

layout Whitespace = [\ \t\n]*;
syntax A = "a";
syntax B = "b";
start syntax C = "c" | A C B;

layout Whitespace = [\ \t\n]*;
lexical Integer = [0-9]+;
start syntax E1 = Integer
               | E "*" E
	       > E "+" E
	       | "(" E ")"
               ;


/*┌───────────────────────────────────────────────────────────────────┐
  │ The REXX language doesn't allow for the changing or overriding of │
  │ syntax per se,  but any of the built-in-functions (BIFs) can be   │
  │ overridden by just specifying your own.                           │
  │                                                                   │
  │ To use the REXX's version of a built-in-function, you simply just │
  │ enclose the BIF in quotation marks (and uppercase the name).      │
  │                                                                   │
  │ The intent is two-fold:  the REXX language doesn't have any       │
  │ reserved words,  nor reserved  BIFs  (Built-In-Functions).        │
  │                                                                   │
  │ So, if you don't know that  VERIFY  is a BIF,  you can just code  │
  │ a subroutine (or function)  with that name (or any name), and not │
  │ worry about your subroutine being pre-empted.                     │
  │                                                                   │
  │ Second:  if you're not satisfied how a BIF works, you can code    │
  │ your own.   This also allows you to front-end a BIF for debugging │
  │ or modifying the BIF's behavior.                                  │
  └───────────────────────────────────────────────────────────────────┘ */
yyy='123456789abcdefghi'

rrr =  substr(yyy,5)                   /*returns  efghi                 */
mmm = 'SUBSTR'(yyy,5)                  /*returns  56789abcdefgji        */
sss = "SUBSTR"(yyy,5)                  /* (same as above)               */
exit                                   /*stick a fork in it, we're done.*/

/*──────────────────────────────────SUBSTR subroutine───────────────────*/
substr: return right(arg(1),arg(2))

/*┌───────────────────────────────────────────────────────────────────┐
  │ Also, some REXX interpreters treat whitespace(s) as blanks   when │
  │ performing comparisons.    Some of the whitespace characters are: │
  │                                                                   │
  │           NL  (newLine)                                           │
  │           FF  (formFeed)                                          │
  │           VT  (vertical tab)                                      │
  │           HT  (horizontal tab or TAB)                             │
  │           LF  (lineFeed)                                          │
  │           CR  (carriage return)                                   │
  │           EOF (end-of-file)                                       │
  │         and/or others.                                            │
  │                                                                   │
  │ Note that some of the above are ASCII or EBCDIC specific.         │
  │                                                                   │
  │ Some REXX interpreters use the   OPTIONS   statement to force     │
  │ REXX to only treat blanks as spaces.                              │
  │                                                                   │
  │ (Both the  verb  and  option  may be in lower/upper/mixed case.)  │
  │                                                                   │
  │ REXX interpreters which don't recognize any  option  won't treat  │
  │ the (below) statement as an error.                                │
  └───────────────────────────────────────────────────────────────────┘ */
options  strict_white_space_comparisons   /*can be in lower/upper/mixed.*/


o1 = new point { x=10 y=20 z=30 }
addmethod(o1,"print", func { see x + nl + y + nl + z + nl } )
o1.print()
Class point
        x y z


class IDVictim

  # Create elements of this man, woman, or child's identification.
  attr_accessor :name, :birthday, :gender, :hometown

  # Allows you to put in a space for anything which is not covered by the
  # preexisting elements.
  def self.new_element(element)
    attr_accessor element
  end

end


' ---------------------------------------------------
' create a file to be run
' RB can run the entire program
'  or execute a function withing the RUNNED program
' ---------------------------------------------------
open "runned.bas" for output as #f                      ' open runned.bas as output

print #f, "text$ = ""I'm rinning the complete program.  ' print this program to the output
Or you can run a function.
The program or function within the RUNNED program
can execute all Run BASIC commands."""

print #f, "
x = displayText(text$)"

print #f, "                                            ' besides RUNNING the entireprogram
Function displayText(text$)                            ' we will execute this function only
print text$                                            '
end function"

' ----------------------------------------
' Execute the entire RUNNED program
' ----------------------------------------
RUN "runned.bas",#handle          ' setup run command to execute runned.bas and give it a handle
render #handle                    ' render the handle will execute the program

' ----------------------------------------
' Execute a function in the RUNNED program
' ----------------------------------------
RUN "runned.bas",#handle          ' setup run command to execute runned.bas and give it a handle
#handle displayText("Welcome!")   ' only execute the function withing the runned program
render #handle                    ' render the handle will execute the program


// dry.rs
use std::ops::{Add, Mul, Sub};

macro_rules! assert_equal_len {
    // The `tt` (token tree) designator is used for
    // operators and tokens.
    ($a:ident, $b: ident, $func:ident, $op:tt) => (
        assert!($a.len() == $b.len(),
                "{:?}: dimension mismatch: {:?} {:?} {:?}",
                stringify!($func),
                ($a.len(),),
                stringify!($op),
                ($b.len(),));
    )
}

macro_rules! op {
    ($func:ident, $bound:ident, $op:tt, $method:ident) => (
        fn $func<T: $bound<T, Output=T> + Copy>(xs: &mut Vec<T>, ys: &Vec<T>) {
            assert_equal_len!(xs, ys, $func, $op);

            for (x, y) in xs.iter_mut().zip(ys.iter()) {
                *x = $bound::$method(*x, *y);
                // *x = x.$method(*y);
            }
        }
    )
}

// Implement `add_assign`, `mul_assign`, and `sub_assign` functions.
op!(add_assign, Add, +=, add);
op!(mul_assign, Mul, *=, mul);
op!(sub_assign, Sub, -=, sub);

mod test {
    use std::iter;
    macro_rules! test {
        ($func: ident, $x:expr, $y:expr, $z:expr) => {
            #[test]
            fn $func() {
                for size in 0usize..10 {
                    let mut x: Vec<_> = iter::repeat($x).take(size).collect();
                    let y: Vec<_> = iter::repeat($y).take(size).collect();
                    let z: Vec<_> = iter::repeat($z).take(size).collect();

                    super::$func(&mut x, &y);

                    assert_eq!(x, z);
                }
            }
        }
    }

    // Test `add_assign`, `mul_assign` and `sub_assign`
    test!(add_assign, 1u32, 2u32, 3u32);
    test!(mul_assign, 2u32, 3u32, 6u32);
    test!(sub_assign, 3u32, 2u32, 1u32);
}


import scala.language.experimental.macros
import scala.reflect.macros.Context

object Macros {
  def impl(c: Context) = {
    import c.universe._
    c.Expr[Unit](q"""println("Hello World")""")
  }

  def hello: Unit = macro impl
}


(define make-list
  [A|D] -> [cons (make-list A) (make-list D)]
  X -> X)

(defmacro info-macro
  [info Exp] -> [output "~A: ~A~%" (make-list Exp) Exp])

(info (* 5 6)) \\ outputs [* 5 6]: 30


class Number {
    method ⊕(arg) {
        self + arg
    }
}

say (21 ⊕ 42)


apiSyslog:priority format:format message:message
    <cdecl: int 'syslog' (int char* char*) >
    ^ self primitiveFailed.


        OPSYN('SAME','IDENT')
        OPSYN('$','*',1)


fun to (a, b) = List.tabulate (b-a,fn i => a+i ) ;
infix 5 to ;


proc loopVar {var from lower to upper script} {
    if {$from ne "from" || $to ne "to"} {error "syntax error"}
    upvar 1 $var v
    if {$lower <= $upper} {
        for {set v $lower} {$v <= $upper} {incr v} {
            uplevel 1 $script
        }
    } else {
        # $upper and $lower really the other way round here
        for {set v $lower} {$v >= $upper} {incr v -1} {
            uplevel 1 $script
        }
    }
}


(defmacro whil ((condition : result) . body)
  (let ((cblk (gensym "cnt-blk-"))
        (bblk (gensym "brk-blk-")))
    ^(macrolet ((break (value) ^(return-from ,',bblk ,value)))
       (symacrolet ((break (return-from ,bblk))
                    (continue (return-from ,cblk)))
         (block ,bblk
           (for () (,condition ,result) ()
             (block ,cblk ,*body)))))))

(let ((i 0))
  (whil ((< i 100))
    (if (< (inc i) 20)
      continue)
    (if (> i 30)
      break)
    (prinl i)))

(prinl
  (sys:expand
    '(whil ((< i 100))
       (if (< (inc i) 20)
         continue)
       (if (> i 30)
         break)
       (prinl i))))


import "meta" for Meta

var genericClass = Fn.new { |cname, fname|
    var s1 = "class %(cname) {\n"
    var s2 = "construct new(%(fname)){\n_%(fname) = %(fname)\n}\n"
    var s3 = "%(fname) { _%(fname) }\n"
    var s4 = "}\nreturn %(cname)\n"
    return Meta.compile(s1 + s2 + s3 + s4).call() // returns the Class object
}

var CFoo = genericClass.call("Foo", "bar")
var foo = CFoo.new(10)
System.print([foo.bar, foo.type])


macro xchg,regpair1,regpair2
;swaps the contents of two registers.
push regpair1
push regpair2
pop regpair1
pop regpair2
endm


#define name [0|1]
#if [0|1|name]
#else, #endif


F middle_three_digits(i)
   V s = String(abs(i))
   assert(s.len >= 3 & s.len % 2 == 1, ‘Need odd and >= 3 digits’)
   R s[s.len I/ 2 - 1 .+ 3]

V passing = [123, 12345, 1234567, 987654321, 10001, -10001, -123, -100, 100, -12345]
V failing = [1, 2, -1, -10, 2002, -2002, 0]
L(x) passing [+] failing
   X.try
      V answer = middle_three_digits(x)
      print(‘middle_three_digits(#.) returned: #.’.format(x, answer))
   X.catch AssertionError error
      print(‘middle_three_digits(#.) returned error: ’.format(x)‘’String(error))


INCLUDE "H6:REALMATH.ACT"
INCLUDE "D2:PRINTF.ACT" ;from the Action! Tool Kit

PROC MiddleThreeDigits(REAL POINTER n CHAR ARRAY res)
  REAL r
  CHAR ARRAY s(15)
  BYTE i

  RealAbs(n,r)
  StrR(r,s)
  i=s(0)
  IF i<3 OR (i&1)=0 THEN
    res(0)=0
  ELSE
    i==RSH 1
    SCopyS(res,s,i,i+2)
  FI
RETURN

PROC Test(CHAR ARRAY s)
  REAL n
  CHAR ARRAY res(4)

  ValR(s,n)
  MiddleThreeDigits(n,res)
  IF res(0) THEN
    PrintF("%9S -> %S%E",s,res)
  ELSE
    PrintF("%9S -> error!%E",s)
  FI
RETURN

PROC Main()
  Put(125) PutE() ;clear the screen

  Test("123")     Test("12345")
  Test("1234567") Test("987654321")
  Test("10001")   Test("-10001")
  Test("-123")    Test("-100")
  Test("100")     Test("-12345")
  Test("1")       Test("2")
  Test("-1")      Test("-10")
  Test("2002")    Test("-2002")
  Test("0")
RETURN


with Ada.Text_IO;

procedure Middle_Three_Digits is

   Impossible: exception;

   function Middle_String(I: Integer; Middle_Size: Positive) return String is
      S: constant String := Integer'Image(I);
      First: Natural := S'First;
      Full_Size, Border: Natural;
   begin
      while S(First) not in '0' .. '9' loop -- skip leading blanks and minus
         First := First + 1;
      end loop;
      Full_Size := S'Last-First+1;
      if (Full_Size < Middle_Size) or (Full_Size mod 2 = 0) then
         raise Impossible;
      else
         Border := (Full_Size - Middle_Size)/2;
         return S(First+Border .. First+Border+Middle_Size-1);
      end if;
   end Middle_String;

   Inputs: array(Positive range <>) of Integer :=
     (123, 12345, 1234567, 987654321, 10001, -10001, -123, -100, 100, -12345,
      1, 2, -1, -10, 2002, -2002, 0);
   Error_Message: constant String := "number of digits must be >= 3 and odd";

   package IIO is new Ada.Text_IO.Integer_IO(Integer);

begin
   for I in Inputs'Range loop
      IIO.Put(Inputs(I), Width => 9);
      Ada.Text_IO.Put(": ");
      begin
         Ada.Text_IO.Put(Middle_String(Inputs(I), 3));
      exception
         when Impossible => Ada.Text_IO.Put("****" & Error_Message & "****");
      end;
      Ada.Text_IO.New_Line;
   end loop;

end Middle_Three_Digits;


# we define a UNION MODE so that our middle 3 digits PROC can #
# return either an integer on success or a error message if   #
# the middle 3 digits couldn't be extracted                   #
MODE EINT = UNION( INT # success value #, STRING # error message # );
# PROC to return the middle 3 digits of an integer.           #
# if this is not possible, an error message is returned       #
# instead                                                     #
PROC middle 3 digits = ( INT number ) EINT:
BEGIN
    # convert the absolute value of the number to a string with the  #
    # minumum possible number characters                             #
    STRING digits     = whole( ABS number, 0 );
    INT    len        = UPB digits;
    IF   len < 3
    THEN
        # number has less than 3 digits #
        # return an error message       #
        "number must have at least three digits"
    ELIF ( len MOD 2 ) = 0
    THEN
        # the number has an even number of digits #
        # return an error message                 #
        "number must have an odd number of digits"
    ELSE
        # the number is suitable for extraction of the middle 3 digits #
        INT first digit pos = 1 + ( ( len - 3 ) OVER 2 );
        # the result is the integer value of the three digits          #
        ( ( ( ABS digits[ first digit pos     ] - ABS "0" ) * 100 )
        + ( ( ABS digits[ first digit pos + 1 ] - ABS "0" ) *  10 )
        + ( ( ABS digits[ first digit pos + 2 ] - ABS "0" )       )
        )
    FI
END; # middle 3 digits #

main: (
    # test the middle 3 digits PROC #
    []INT test values = (    123,  12345, 1234567, 987654321
                        ,  10001, -10001,    -123,      -100
                        ,    100, -12345
                          # the following values should fail #
                        , 1, 2, -1, -10, 2002, -2002, 0
                        );
    FOR test number FROM LWB test values TO UPB test values
    DO
        CASE middle 3 digits( test values[ test number ] )
        IN
        ( INT     success value ):    # got the middle 3 digits #
            printf( ( $ 11z-d, " : ", 3d $
                    , test values[ test number ]
                    , success value
                    )
                  )
            ,
        ( STRING  error message  ):    # got an error message   #
            printf( ( $ 11z-d, " : ", n( UPB error message )a $
                    , test values[ test number ]
                    , error message
                    )
                  )
        ESAC;
        print( ( newline ) )
    OD
)


begin
    % record structure that will be used to return the middle 3 digits of a number   %
    % if the middle three digits can't be determined, isOk will be false and message %
    % will contain an error message                                                  %
    % if the middle 3 digts can be determined, middle3 will contain the middle 3     %
    % digits and isOk will be true                                                   %
    record MiddleThreeDigits ( integer middle3; logical isOk; string(80) message );

    % finds the middle3 digits of a number or describes why they can't be found      %
    reference(MiddleThreeDigits) procedure findMiddleThreeDigits ( integer value number ) ;
        begin
            integer n, digitCount, d;

            n          := abs( number );
            % count the number of digits the number has %
            digitCount := if n = 0 then 1 else 0;
            d          := n;
            while d > 0 do begin
                digitCount := digitCount + 1;
                d          := d div 10
            end while_d_gt_0 ;
            if      digitCount < 3        then MiddleThreeDigits( 0, false, "Number must have at least 3 digits"       )
            else if not odd( digitCount ) then MiddleThreeDigits( 0, false, "Number must have an odd number of digits" )
            else begin
                % can find the middle three digits %
                integer m3;
                m3 := n;
                for d := 1 until ( digitCount - 3 ) div 2 do m3 := m3 div 10;
                MiddleThreeDigits( m3 rem 1000, true, "" )
            end
        end findMiddleThreeDigits ;

    % test the findMiddleThreeDigits procedure %
    for n := 123, 12345, 1234567, 987654321, 10001, -10001, -123, -100, 100, -12345, 1, 2, -1, -10, 2002, -2002, 0 do begin
        reference(MiddleThreeDigits) m3;
        i_w := 10; s_w := 0; % set output formating %
        m3 := findMiddleThreeDigits( n );
        write( n, ": " );
        if not isOk(m3) then writeon( message(m3) )
        else begin
            % as we return the middle three digits as an integer, we must manually 0 pad %
            if middle3(m3) < 100 then writeon( "0" );
            if middle3(m3) <  10 then writeon( "0" );
            writeon( i_w := 1, middle3(m3) )
        end
    end for_n

end.


on middle3Digits(n)
    try
        n as number -- Errors if n isn't a number or coercible thereto.
        set s to n as text -- Keep for the ouput string.
        if (n mod 1 is not 0) then error (s & " isn't an integer value.")
        if (n < 0) then set n to -n
        if (n < 100) then error (s & " has fewer than three digits.")
        -- Coercing large numbers to text may result in E notation, so extract the digit values individually.
        set theDigits to {}
        repeat until (n = 0)
            set beginning of theDigits to n mod 10 as integer
            set n to n div 10
        end repeat
        set c to (count theDigits)
        if (c mod 2 is 0) then error (s & " has an even number of digits.")
    on error errMsg
        return "middle3Digits handler got an error: " & errMsg
    end try
    set i to (c - 3) div 2 + 1
    set {x, y, z} to items i thru (i + 2) of theDigits

    return "The middle three digits of " & s & " are " & ((x as text) & y & z & ".")
end middle3Digits

-- Test code:
set testNumbers to {123, 12345, 1234567, "987654321", "987654321" as number, 10001, -10001, -123, -100, 100, -12345, 1, 2, -1, -10, 2002, -2002, 0}
set output to {}
repeat with thisNumber in testNumbers
    set end of output to middle3Digits(thisNumber)
end repeat
set astid to AppleScript's text item delimiters
set AppleScript's text item delimiters to linefeed
set output to output as text
set AppleScript's text item delimiters to astid
return output


middleThree: function [num][
    n: to :string abs num
    if 3 > size n -> return "Number must have at least three digits"
    if even? size n -> return "Number must have an odd number of digits"

    middle: ((size n)/2)- 1
    return slice n middle middle+2
]

samples: @[
    123, 12345, 1234567, 987654321, 10001, neg 10001, neg 123, neg 100, 100, neg 12345,
    1, 2, neg 1, neg 10, 2002, neg 2002, 0
]

loop samples 's [
    print [pad to :string s 10 ":" middleThree s]
]


(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
#include
"share/HATS/atspre_staload_libats_ML.hats"
//
(* ****** ****** *)
//
extern
fun
int2digits(x: int): list0(int)
//
(* ****** ****** *)

implement
int2digits(x) =
loop(x, list0_nil) where
{
//
fun
loop
(
 x: int, res: list0(int)
) : list0(int) =
  if x > 0 then loop(x/10, list0_cons(x%10, res)) else res
//
} (* end of [int2digits] *)

(* ****** ****** *)

extern
fun
Middle_three_digits(x: int): void

(* ****** ****** *)

implement
Middle_three_digits
  (x0) = let
//
val x1 =
(
if x0 >= 0 then x0 else ~x0
) : int
//
fun
skip
(
ds: list0(int), k: int
) : list0(int) =
  if k > 0 then skip(ds.tail(), k-1) else ds
//
val ds =
  int2digits(x1)
//
val n0 = length(ds)
//
in
//
if
(n0 <= 2)
then
(
println! ("Middle-three-digits(", x0, "): Too small!")
)
else
(
if
(n0 % 2 = 0)
then
(
println!
(
"Middle-three-digits(", x0, "): Even number of digits!"
)
)
else let
  val ds =
    skip(ds, (n0-3)/2)
  val-list0_cons(d1, ds) = ds
  val-list0_cons(d2, ds) = ds
  val-list0_cons(d3, ds) = ds
in
  println! ("Middle-three-digits(", x0, "): ", d1, d2, d3)
end // end of [else]
)
//
end // end of [Middle_three_digits]

(* ****** ****** *)

implement
main0() =
{
//
val
thePassing =
g0ofg1
(
$list{int}
(
  123
, 12345
, 1234567
, 987654321
, 10001, ~10001
, ~123, ~100, 100, ~12345
)
)
val
theFailing =
g0ofg1($list{int}(1, 2, ~1, ~10, 2002, ~2002, 0))
//
val () = thePassing.foreach()(lam x => Middle_three_digits(x))
val () = theFailing.foreach()(lam x => Middle_three_digits(x))
//
} (* end of [main0] *)

(* ****** ****** *)


Numbers:="123,12345,1234567,987654321,10001,-10001,-123,-100,100,-12345,1,2,-1,-10,2002,-2002,0"
Loop, parse, Numbers, `,
{
	if A_LoopField is not number
		log := log . A_LoopField . "`t: Not a valid number`n"
	else if((d:=StrLen(n:=RegExReplace(A_LoopField,"\D")))<3)
		log := log . A_LoopField . "`t: Too short`n"
	else if(!Mod(d,2))
		log := log . A_LoopField . "`t: Not an odd number of digits`n"
	else
		log := log . A_LoopField . "`t: " . SubStr(n,((d-3)//2)+1,3) . "`n"
}
MsgBox % log


#!/bin/awk -f
# use as: awk -f middle_three_digits.awk

BEGIN {
	n = split("123 12345 1234567 987654321 10001 -10001 -123 -100 100 -12345 1 2 -1 -10 2002 -2002 0", arr)

	for (i=1; i<=n; i++) {
		if (arr[i] !~ /^-?[0-9]+$/) {
			printf("%10s : invalid input: not a number\n", arr[i])
			continue
		}

		num = arr[i]<0 ? -arr[i]:arr[i]
		len = length(num)

		if (len < 3) {
			printf("%10s : invalid input: too few digits\n", arr[i])
			continue
		}

		if (len % 2 == 0) {
			printf("%10s : invalid input: even number of digits\n", arr[i])
			continue
		}

		printf("%10s : %s\n", arr[i], substr(num, len/2, 3))
	}
}


@echo off
setlocal enabledelayedexpansion

	%== Initialization ==%
set "numbers=123, 12345, 1234567, 987654321, 10001, -10001, -123, -100, 100, -12345, 1, 2, -1, -10, 2002, -2002, 0"

	%== The Main Thing ==%
for %%N in (%numbers%) do (
	call :middle3 %%N
)
echo.
pause
exit /b 0
	%==/The Main Thing ==%

	%== The Procedure ==%
:middle3

	set str=%1
	%== Making sure that str is positive ==%
	if !str! lss 0 set /a str*=-1

	%== Alternative for finding the string length ==%
	%== But this has a limit of 1000 characters ==%
	set leng=0&if not "!str!"=="" for /l %%. in (0,1,1000) do if not "!str:~%%.,1!"=="" set /a leng+=1

	if !leng! lss 3 (
		echo.%~1:		[ERROR] Input too small.
		goto :EOF
	)

	set /a "test2=leng %% 2,trimmer=(leng - 3) / 2"

	if !test2! equ 0 (
		echo.%~1:		[ERROR] Even number of digits.
		goto :EOF
	)

	%== Passed the tests. Now, really find the middle 3 digits... ==%
	if !trimmer! equ 0 (
		echo.%~1:		!str!
	) else (
		echo.%~1:		!str:~%trimmer%,-%trimmer%!
	)
	goto :EOF
	%==/The Procedure ==%


#include <stdio.h>
#include <stdlib.h>
#include <string.h>

// we return a static buffer; caller wants it, caller copies it
char * mid3(int n)
{
	static char buf[32];
	int l;
	sprintf(buf, "%d", n > 0 ? n : -n);
	l = strlen(buf);
	if (l < 3 || !(l & 1)) return 0;
	l = l / 2 - 1;
	buf[l + 3] = 0;
	return buf + l;
}

int main(void)
{
	int x[] = {123, 12345, 1234567, 987654321, 10001, -10001,
		-123, -100, 100, -12345, 1, 2, -1, -10, 2002, -2002, 0,
		1234567890};

	int i;
	char *m;
	for (i = 0; i < sizeof(x)/sizeof(x[0]); i++) {
		if (!(m = mid3(x[i])))
			m = "error";
		printf("%d: %s\n", x[i], m);
	}
	return 0;
}


#include <iostream>

std::string middleThreeDigits(int n)
{
    auto number = std::to_string(std::abs(n));
    auto length = number.size();

    if (length < 3) {
        return "less than three digits";
    } else if (length % 2 == 0) {
        return "even number of digits";
    } else {
        return number.substr(length / 2 - 1, 3);
    }
}

int main()
{
    auto values {123, 12345, 1234567, 987654321, 10001,
                 -10001, -123, -100, 100, -12345,
                 1, 2, -1, -10, 2002, -2002, 0};

    for (auto&& v : values) {
        std::cout << "middleThreeDigits(" << v << "): " <<
                     middleThreeDigits(v) << "\n";
    }
}


using System;

namespace RosettaCode
{
    class Program
    {
        static void Main(string[] args)
        {
            string text = Math.Abs(int.Parse(Console.ReadLine())).ToString();
            Console.WriteLine(text.Length < 2 || text.Length % 2 == 0 ? "Error" : text.Substring((text.Length - 3) / 2, 3));
        }
    }
}


(defn middle3 [v]
  (let [no (Math/abs v)
        digits (str no)
        len (count digits)]
    (cond
      (< len 3) :too_short
      (even? len) :no_middle_in_even_no_of_digits
      :else (let [mid (/ len 2)
                  start (- mid 2)]
              (apply str
                     (take 3
                           (nthnext digits start)))))))

(def passes '(123 12345 1234567 987654321 10001 -10001 -123 -100 100 -12345))
(def fails '(1 2 -1 -10 2002 -2002 0))


middle_three_digits = proc (n: int) returns (string)
                      signals (too_small, even_length)
    s: string := int$unparse(int$abs(n))
    if string$size(s) < 3 then signal too_small end
    if string$size(s) // 2 = 0 then signal even_length end
    return(string$substr(s, string$size(s)/2, 3))
end middle_three_digits

start_up = proc ()
    po: stream := stream$primary_output()
    tests: sequence[int] := sequence[int]$
        [123,12345,1234567,987654321,10001,-10001,-123,-100,100,-12345,
         1,2,-1,-10,2002,-2002,0]

    for test: int in sequence[int]$elements(tests) do
        stream$putright(po, int$unparse(test) || ": ", 11)

        stream$putl(po, middle_three_digits(test))
        except
            when too_small: stream$putl(po, "Too small")
            when even_length: stream$putl(po, "Even length")
        end
    end
end start_up


identification division.
program-id. middle3.
environment division.
data division.
working-storage section.
01  num                 pic 9(9).
    88 num-too-small    values are -99 thru 99.
01  num-disp            pic ---------9.

01  div                 pic 9(9).
01  mod                 pic 9(9).
01  mod-disp            pic 9(3).

01  digit-counter       pic 999.
01  digit-div           pic 9(9).
    88  no-more-digits  value 0.
01  digit-mod           pic 9(9).
    88  is-even         value 0.

01  multiplier          pic 9(9).

01  value-items.
    05  filler  pic s9(9) value 123.
    05  filler  pic s9(9) value 12345.
    05  filler  pic s9(9) value 1234567.
    05  filler  pic s9(9) value 987654321.
    05  filler  pic s9(9) value 10001.
    05  filler  pic s9(9) value -10001.
    05  filler  pic s9(9) value -123.
    05  filler  pic s9(9) value -100.
    05  filler  pic s9(9) value 100.
    05  filler  pic s9(9) value -12345.
    05  filler  pic s9(9) value 1.
    05  filler  pic s9(9) value 2.
    05  filler  pic s9(9) value -1.
    05  filler  pic s9(9) value -10.
    05  filler  pic s9(9) value 2002.
    05  filler  pic s9(9) value -2002.
    05  filler  pic s9(9) value 0.

01  value-array redefines value-items.
    05  items   pic s9(9)  occurs 17 times indexed by item.

01  result  pic x(20).

procedure division.
10-main.
    perform with test after varying item from 1 by 1 until items(item) = 0
        move items(item) to num
        move items(item) to num-disp
        perform 20-check
        display num-disp " --> " result
    end-perform.
    stop run.

20-check.
    if num-too-small
        move "Number too small" to result
        exit paragraph
    end-if.

    perform 30-count-digits.
    divide digit-counter by 2 giving digit-div remainder digit-mod.
    if is-even
        move "Even number of digits" to result
        exit paragraph
    end-if.

    *> if digit-counter is 5, mul by 10
    *> if digit-counter is 7, mul by 100
    *> if digit-counter is 9, mul by 1000

    if digit-counter > 3
        compute multiplier rounded = 10 ** (((digit-counter - 5) / 2) + 1)
        divide num by multiplier giving num
        divide num by 1000 giving div remainder mod
        move mod to mod-disp
    else
        move num to mod-disp
    end-if.
    move mod-disp to result.
    exit paragraph.

30-count-digits.
    move zeroes to digit-counter.
    move num to digit-div.
    perform with test before until no-more-digits
        divide digit-div by 10 giving digit-div remainder digit-mod
        add 1 to digit-counter
    end-perform.
    exit paragraph.


(defun mid3 (n)
  (let ((a (abs n))
        (hmd)) ; how many digits
    (labels ((give (fmt &optional x y) (return-from mid3 (format nil fmt x y)))
             (need (x) (give "Need ~a digits, not ~d." x hmd))
             (nbr (n) (give "~3,'0d" n)))
      (when (zerop n) (give "Zero is 1 digit"))
      (setq hmd (truncate (1+ (log a 10))))
      (cond ((< hmd 3) (need "3+"))
            ((= hmd 3) (nbr a))
            ((evenp hmd) (need "odd number of"))
            (t (nbr (mod (truncate a (expt 10 (/ (- hmd 3) 2))) 1000)))))))


import std.stdio, std.traits, std.conv;

string middleThreeDigits(T)(in T n) pure nothrow if (isIntegral!T) {
    auto s = n < 0 ? n.text[1 .. $] : n.text;
    auto len = s.length;
    if (len < 3 || len % 2 == 0)
        return "Need odd and >= 3 digits";
    auto mid = len / 2;
    return s[mid - 1 .. mid + 2];
}

void main() {
    immutable passing = [123, 12345, 1234567, 987654321, 10001, -10001,
            -123, -100, 100, -12345, long.min, long.max];
    foreach (immutable n; passing)
        writefln("middleThreeDigits(%s): %s", n, middleThreeDigits(n));

    immutable failing = [1, 2, -1, -10, 2002, -2002, 0,int.min,int.max];
    foreach (immutable n; failing)
        writefln("middleThreeDigits(%s): %s", n, middleThreeDigits(n));
}


import'dart:math';
  int length(int x)
  {
    int i,y;
  for(i=0;;i++)
  {
    y=pow(10,i);
    if(x%y==x)
      break;
  }
    return i;
  }
 int middle(int x,int l)
  {
 int a=(x/10)-((x%10)/10);
  int b=a%(pow(10,l-2));
  int l2=length(b);
      if(l2==3)
      {
        return b;
      }
    if(l2!=3)
      {
        return middle(b,l2);
      }
  return 0;
  }

main()
{
  int x=-100,y;
  if(x<0)
 x=-x;
  int l=length(x);
  if(l.isEven||x<100)
  {print('error');}
    if(l==3)
  {print('$x');}

  if(l.isOdd&& x>100)
  {
   y=middle(x,l);
  print('$y');
  }
}


$ list = "123,12345,1234567,987654321,10001,-10001,-123,-100,100,-12345,1,2,-1,-10,2002,-2002,0"
$ i = 0
$ loop:
$  number = f$element( i, ",", list )
$  if number .eqs. "," then $ exit
$  abs_number = number - "-"
$  len = f$length( abs_number )
$  if len .lt. 3 .or. .not. len
$  then
$   write sys$output f$fao( "!9SL: ", f$integer( number )), "has no middle three"
$  else
$   write sys$output f$fao( "!9SL: ", f$integer( number )), f$extract( ( len - 3 ) / 2, 3, abs_number )
$  endif
$  i = i + 1
$  goto loop


class
	APPLICATION

create
	make

feature

	make
			-- Test of middle_three_digits.
		local
			test_1, test_2: ARRAY [INTEGER]
		do
			test_1 := <<123, 12345, 1234567, 987654321, 10001, -10001, -123, -100, 100, -12345>>
			test_2 := <<1, 2, -1, -10, 2002, -2002, 0>>
			across
				test_1 as t
			loop
				io.put_string ("The middle three digits of " + t.item.out + " are: %T ")
				io.put_string (middle_three_digits (t.item) + "%N")
			end
			across
				test_2 as t
			loop
				io.put_string ("The middle three digits of " + t.item.out + " are: %T")
				io.put_string (middle_three_digits (t.item) + "%N")
			end
		end

	middle_three_digits (n: INTEGER): STRING
			-- The middle three digits of 'n'.
		local
			k, i: INTEGER
			in: STRING
		do
			create in.make_empty
			in := n.out
			if n < 0 then
				in.prune ('-')
			end
			create Result.make_empty
			if in.count < 3 then
				io.put_string (" Not enough digits. ")
			elseif in.count \\ 2 = 0 then
				io.put_string (" Even number of digits. ")
			else
				i := (in.count - 3) // 2
				from
					k := i + 1
				until
					k > i + 3
				loop
					Result.extend (in.at (k))
					k := k + 1
				end
			end
		ensure
			length_is_three: Result.count = 3 or Result.count = 0
		end

end


import system'routines;
import extensions;

middleThreeDigits(int n)
{
    string s := n.Absolute.toString();
    int len := s.Length;
    if(len<3)
    {
        InvalidArgumentException.new:"n must have 3 digits or more".raise()
    }
    else if(len.isEven())
    {
        InvalidArgumentException.new:"n must have an odd number of digits".raise()
    };

    int mid := len / 2;

    ^ s.Substring(mid-1,3)
}

public program()
{
    new int[]{123, 12345, 1234567, 987654321, 10001, -10001, -123, -100, 100, -12345, 1, 2, -1, -10, 2002, -2002, 0}
        .forEach:(n)
        {
            console.printLine("middleThreeDigits(",n,"):",middleThreeDigits(n) | on:(e => e.Message))
        }
}


defmodule Middle do
  def three(num) do
    n = num |> abs |> to_string

    case {n,String.length(n) > 2,even?(n)} do
      {n, true, false} ->
        cut(n)
      {_, false, _} ->
        raise "Number must have at least three digits"
      {_, _, true} ->
        raise "Number must have an odd number of digits"
    end
  end

  defp even?(n), do: rem(String.length(n),2) == 0
  defp cut(n), do: String.slice(n,(div(String.length(n),2) - 1),3)
end

valids = [123, 12345, 1234567, 987654321, 10001, -10001, -123, -100, 100, -12345]
Enum.each(valids, fn n -> :io.format "~10w : ~s~n", [n, Middle.three(n)] end)

errors = [1, 2, -1, -10, 2002, -2002, 0]
Enum.each(errors, fn n ->
  :io.format "~10w : ", [n]
  try do
    IO.puts Middle.three(n)
  rescue
    e -> IO.puts e.message
  end
end)


%
-module(middle_three_digits).
-export([main/0]).

main() ->
	digits(123),
	digits(12345),
	digits(1234567),
	digits(987654321),
	digits(10001),
	digits(-10001),
	digits(-123),
	digits(-100),
	digits(100),
	digits(-12345),
	digits(1),
	digits(2),
	digits(-1),
	digits(-10),
	digits(2002),
	digits(-2002),
	digits(0).

digits(N) when N < 0 ->
	digits(-N);
digits(N) when (N div 100) =:= 0  ->
	io:format("too small\n");
digits(N) ->
	K=length(integer_to_list(N)),
	if (K rem 2) =:= 0 ->
		io:format("even number of digits\n");
	true ->
		loop((K-3) div 2 , N)
	end.

loop(0, N) ->
	io:format("~3..0B~n",[N rem 1000]);
loop(X,N)  when X>0 ->
	loop(X-1, N div 10).


PROGRAM MIDDLE

!$DOUBLE

FUNCTION LUNG(N)
   LUNG=LEN(STR$(INT(ABS(N))))+1
END FUNCTION

FUNCTION NCNT(N)
    NCNT=VAL(MID$(STR$(INT(ABS(N))),(LUNG(N)-1)/2,3))
END FUNCTION

FUNCTION EVEN(N)
    EVEN=INT(N/2)=N/2
END FUNCTION

PROCEDURE NUMBER_EXAM(N->R$)
    R$=""   LG%=LUNG(N)-2
    IF EVEN(LG%) THEN R$="?EVEN,"  END IF
    IF LG%<3 THEN
             R$=R$+"ONLY"+STR$(LG%)+" DIGIT"
             IF LG%=1 THEN
                 R$=R$+"S"
             END IF
    END IF
    IF RIGHT$(R$,1)="," THEN R$=LEFT$(R$,LEN(R$)-1)   EXIT PROCEDURE END IF
    IF LEFT$(R$,1)="?" THEN EXIT PROCEDURE END IF
    IF R$<>"" THEN R$="?"+R$   EXIT PROCEDURE END IF
    R$=STR$(NCNT(N))
    IF LEFT$(R$,1)=" " THEN R$=MID$(R$,2) END IF
    IF LEN(R$)=1 THEN R$="00"+R$  END IF
    IF LEN(R$)=2 THEN R$="0"+R$   END IF
END PROCEDURE

BEGIN
    DATA(123,12345,1234567,987654321,10001,-10001,-123,-100,100,-12345)
    DATA(1,2,-1,-10,2002,-2002,0)
    FOR I%=1 TO 17 DO
        READ(N)
        PRINT(N;"  ",)
        NUMBER_EXAM(N->R$)
        PRINT(R$)
    END FOR
END PROGRAM


USING: combinators formatting io kernel math math.parser
sequences ;
IN: rosetta-code.middle-three-digits

CONSTANT: test-values {
    123 12345 1234567 987654321 10001 -10001
    -123 -100 100 -12345 1 2 -1 -10 2002 -2002 0
}

: (middle-three) ( str -- str' )
    [ [email protected] [ 1 - ] [ 2 + ] bi ] [ subseq ] bi ;

: too-short ( -- )
    "Number must have at least three digits." print ;

: number-even ( -- )
    "Number must have an odd number of digits." print ;

: middle-three ( n -- )
    abs number>string {
        { [ dup length 3 < ] [ drop too-short ] }
        { [ dup length even? ] [ drop number-even ] }
        [ (middle-three) print ]
    } cond ;

: main ( -- )
    test-values [ dup "%9d : " printf middle-three ] each ;

MAIN: main


: middle3          ( n1 -- a n2)
  abs s>d <# #s #> dup 2/ 0<> over 1 and 0<> and
  if 2/ 1- chars + 3 else drop 0 then
;


!-*- mode: compilation; default-directory: "/tmp/" -*-
!Compilation started at Sat Jun  1 14:48:41
!
!a=./f && make $a && OMP_NUM_THREADS=2 $a < unixdict.txt # some of the compilation options and redirection from unixdict.txt are vestigial.
!gfortran -std=f2008 -Wall -fopenmp -ffree-form -fall-intrinsics -fimplicit-none f.f08 -o f
!                 123  123
!               12345  234
!             1234567  345
!           987654321  654
!               10001  000
!              -10001  000
!                -123  123
!                -100  100
!                 100  100
!              -12345  234
!                   1  Too short
!                   2  Too short
!                  -1  Too short
!                 -10  Too short
!                2002  Digit count too even
!               -2002  Digit count too even
!                   0  Too short
!
!Compilation finished at Sat Jun  1 14:48:41

program MiddleMuddle
  integer, dimension(17) :: itest, idigits
  integer :: i, n
  data itest/123,12345,1234567,987654321,10001,-10001,-123,-100,100,-12345,1,2,-1,-10,2002,-2002,0/
  do i = 1, size(itest)
    call antibase(10, abs(itest(i)), idigits, n)
    write(6,'(i20,2x,a20)') itest(i), classifym3(idigits, n)
    if (0 .eq. itest(i)) exit
  end do

contains

  logical function even(n)
    integer, intent(in) :: n
    even = 0 .eq. iand(n,1)
  end function even

  function classifym3(iarray, n) result(s)
    integer, dimension(:), intent(in) :: iarray
    integer, intent(in) :: n
    character(len=20) :: s
    integer :: i,m
    if (n < 3) then
      s = 'Too short'
    else if (even(n)) then
      s = 'Digit count too even'
    else
      m = (n+1)/2
      write(s,'(3i1)')(iarray(i), i=m+1,m-1,-1)
    end if
  end function classifym3

  subroutine antibase(base, m, digits, n) ! digits ordered by increasing significance
    integer, intent(in) :: base, m
    integer, intent(out) :: n  ! the number of digits
    integer, dimension(:), intent(out) :: digits
    integer :: em
    em = m
    do n=1, size(digits)
      digits(n) = mod(em, base)
      em = em / base
      if (0 .eq. em) return
    end do
    stop 'antibase ran out of space to store result'
  end subroutine antibase

end program MiddleMuddle


' FB 1.05.0 Win64

Function middleThreeDigits (n As Integer) As String
  If n < 0 Then n = -n
  If n < 100 Then Return ""  '' error code
  If n < 1000 Then Return Str(n)
  If n < 10000 Then Return ""
  Dim ns As String = Str(n)
  If Len(ns) Mod 2 = 0 Then Return ""  '' need to have an odd number of digits for there to be 3 middle
  Return Mid(ns, Len(ns) \ 2, 3)
End Function

Dim a(1 To 16) As Integer => _
{123, 12345, 1234567, 987654321, 10001, -10001, -123, -100, 100, -123451, 2, -1, -10, 2002, -2002, 0}

Dim As Integer i
Dim As String result

Print "The 3 middle digits of the following numbers are : "
Print
For i = 1 To 16
  result = middleThreeDigits(a(i))
  Print a(i), " => ";
  If result <> "" Then
    Print result
  Else
    Print "Error: does not have 3 middle digits"
  End If
Next
Print
Print "Press any key to quit"
Sleep


Public Sub Main()
Dim iList As Integer[] = [123, 12345, 1234567, 987654321, 10001,
 -10001, -123, -100, 100, -12345, 1, 2, -1, -10, 2002, -2002, 0]    'Array of integers to process
Dim sTemp As String                                                 'Temp string
Dim siCount As Short                                                'Counter
Dim sAnswer As New String[]                                         'Array, resons for failure or 'middle three digits'

For siCount = 0 To iList.Max                                        'Loop through the integers
  sTemp = Str(Abs(iList[siCount]))                                  'Convert integer to positive and place in sTemp as a string
  If Len(sTemp) < 3 Then                                            'If sTemp has less than 3 characters then..
    sAnswer.Add("This integer has less than 3 characters")          'Place text in sAnswers
  Else If Even(Len(sTemp)) Then                                     'Else If sTemp is of even length then
    sAnswer.Add("This integer has an even length")                  'Place text in sAnswers
  Else                                                              'Else..
    sAnswer.Add(Mid(sTemp, Int(Len(sTemp) / 2), 3))                 'Place the middle 3 digits in sAnswer
  Endif
Next

For siCount = 0 To iList.Max                                        'Loop through the integers
  Print Space$(10 - Len(Str(iList[siCount]))) &
    iList[siCount] & " : " & sAnswer[siCount]                       'Print out results
Next

End


package m3

import (
    "errors"
    "strconv"
)

var (
    ErrorLT3  = errors.New("N of at least three digits required.")
    ErrorEven = errors.New("N with odd number of digits required.")
)

func Digits(i int) (string, error) {
    if i < 0 {
        i = -i
    }
    if i < 100 {
        return "", ErrorLT3
    }
    s := strconv.Itoa(i)
    if len(s)%2 == 0 {
        return "", ErrorEven
    }
    m := len(s) / 2
    return s[m-1 : m+2], nil
}


var valid = {123, 12345, 1234567, 987654321, 10001, -10001, -123, -100, 100, -12345}
valid.each(\ num ->print(middleThree(num)))

var errant = {1, 2, -1, -10, 2002, -2002, 0}
errant.each(\ num ->print(middleThree(num)))

function middleThree(x: int) : String {
  var s = Math.abs(x) as String
  if(s.length < 3) return "Error: ${x} has less than 3 digits"
  if(s.length % 2 == 0) return "Error: ${x} has an even number of digits"
  var start = (s.length / 2) - 1
  return s.substring(start, start + 3)
}


def middleThree(Number number) {
    def text = Math.abs(number) as String
    assert text.size() >= 3 : "'$number' must be more than 3 numeric digits"
    assert text.size() % 2 == 1 : "'$number' must have an odd number of digits"

    int start = text.size() / 2 - 1
    text[start..(start+2)]
}


mid3 :: Int -> Either String String
mid3 n
  | m < 100 = Left "is too small"
  | even lng = Left "has an even number of digits"
  | otherwise = Right . take 3 $ drop ((lng - 3) `div` 2) s
  where
    m = abs n
    s = show m
    lng = length s

-- TEST --------------------------------------------------------
main :: IO ()
main = do
  let xs =
        [ 123
        , 12345
        , 1234567
        , 987654321
        , 10001
        , -10001
        , -123
        , -100
        , 100
        , -12345
        , 1
        , 2
        , -1
        , -10
        , 2002
        , -2002
        , 0
        ]
      w = maximum $ (length . show) <$> xs
  (putStrLn . unlines) $
    (\n ->
        justifyRight w ' ' (show n) ++
        " -> " ++ either ((>>= id) . ("(" :) . (: [")"])) id (mid3 n)) <$>
    xs
  where
    justifyRight :: Int -> Char -> String -> String
    justifyRight n c s = drop (length s) (replicate n c ++ s)


procedure main(a)
   every n := !a do write(right(n,15)," -> ",midM(n))
end

procedure midM(n,m)
   /m := 3
   n := abs(n)
   return n ? if (*n >= m) then
                 if (((*n-m) % 2) = 0) then (move((*n - m)/2),move(m))
                 else "wrong number of digits"
              else "too short"
end


asString=: ":"0                NB. convert vals to strings
getPfxSize=: [: -:@| 3 -~ #    NB. get size of prefix to drop before the 3 middle digits
getMid3=: (3 {. getPfxSize }. ,&'err') :: ('err'"_)  NB. get 3 middle digits or return 'err'
getMiddle3=: [email protected]@:|


public class MiddleThreeDigits {

    public static void main(String[] args) {
        final long[] passing = {123, 12345, 1234567, 987654321, 10001, -10001,
            -123, -100, 100, -12345, Long.MIN_VALUE, Long.MAX_VALUE};

        final int[] failing = {1, 2, -1, -10, 2002, -2002, 0, Integer.MIN_VALUE,
            Integer.MAX_VALUE};

        for (long n : passing)
            System.out.printf("middleThreeDigits(%s): %s\n", n, middleThreeDigits(n));

        for (int n : failing)
            System.out.printf("middleThreeDigits(%s): %s\n", n, middleThreeDigits(n));
    }

    public static <T> String middleThreeDigits(T n) {
        String s = String.valueOf(n);
        if (s.charAt(0) == '-')
            s = s.substring(1);
        int len = s.length();
        if (len < 3 || len % 2 == 0)
            return "Need odd and >= 3 digits";
        int mid = len / 2;
        return s.substring(mid - 1, mid + 2);
    }
}


using Printf

function middle3(n::Integer)
    l = ndigits(n)
    iseven(l) && error("n must have an odd number of digits")
    l < 3 && error("n must have 3 digits or more")
    mid = (l + 1) ÷ 2
    abs(n) ÷ 10^(mid-2) % 10^3
end

for n = [123, 12345, 1234567, 987654321, 10001, -10001, -123,
         -100, 100, -12345, 1, 2, -1, -10, 2002, -2002, 0]
    @printf("%10d -> %s\n", n, try middle3(n) catch e e.msg end)
end


fun middleThree(x: Int): Int? {
    val s = Math.abs(x).toString()
    return when {
        s.length < 3 -> null // throw Exception("too short!")
        s.length % 2 == 0 -> null // throw Exception("even number of digits")
        else -> ((s.length / 2) - 1).let { s.substring(it, it + 3) }.toInt()
    }
}

fun main(args: Array<String>) {
    println(middleThree(12345)) // 234
    println(middleThree(1234)) // null
    println(middleThree(1234567)) // 345
    println(middleThree(123))// 123
    println(middleThree(123555)) //null
}


{def S 123 12345 1234567 987654321 10001 -10001 -123 -100 100 -12345
       1 2 -1 -10 2002 -2002 0}
-> S

{def middle3digits
 {lambda {:w}
  {let { {:w {abs :w}}
         {:l {W.length {abs :w}}}
       } {if {= {% :l 2} 0}
          then has an even number of digits
          else {if {< :l 3}
          then has not enough digits
          else {W.get {- {/ :l 2} 1} :w}
               {W.get {/ :l 2} :w}
               {W.get {+ {/ :l 2} 1} :w} }}}}}
-> middle3digits

{table
{S.map {lambda {:i}
       {tr {td {@ style="text-align:right;"}:i:}
           {td {middle3digits :i}}}}
       {S}} }
->
   123: 	123
   12345: 	234
   1234567: 	345
 987654321: 	654
     10001: 	000
    -10001: 	000
      -123: 	123
      -100: 	100
       100: 	100
    -12345: 	234
         1: 	has not enough digits
         2: 	has not enough digits
        -1: 	has not enough digits
       -10: 	has an even number of digits
      2002: 	has an even number of digits
     -2002: 	has an even number of digits
         0: 	has not enough digits


define middlethree(value::integer) => {
	local(
		pos_value	= math_abs(#value),
		stringvalue	= #pos_value -> asstring,
		intlength	= #stringvalue -> size,
		middle		= integer((#intlength + 1) / 2),
		prefix		= string(#value) -> padleading(15)& + ': '
	)

	#intlength < 3 ? return #prefix + 'Error: too few digits'
	not(#intlength % 2) ? return #prefix + 'Error: even number of digits'

	return #prefix + #stringvalue -> sub(#middle -1, 3)

}
'
'
with number in array(123, 12345, 1234567, 987654321, 10001, -10001, -123, -100, 100, -12345, 1, 2, -1, -10, 2002, -2002, 0) do {^

	middlethree(#number)
	'
'
^}
'
'


to middle3digits :n
  if [less? :n 0] [make "n minus :n]
  local "len make "len count :n
  if [less? :len 3] [(throw "error [Number must have at least 3 digits])]
  if [equal? 0 modulo :len 2] [(throw "error [Number must have odd number of digits])]
  while [greater? count :n 3] [
    make "n butlast butfirst :n
  ]
  output :n
end

foreach [123 12345 1234567 987654321 10001 -10001 -123 -100 100 -12345
         1 2 -1 -10 2002 -2002 0] [
    type sentence (word ? ": char 9) runresult [if [less? count ? 7] [char 9]]
    make "mid runresult [catch "error [middle3digits ?]]
    print ifelse [empty? :mid] [item 2 error] [:mid]
]

bye


function middle_three(n)
	if n < 0 then
		n = -n
	end

	n = tostring(n)
	if #n % 2 == 0 then
		return "Error: the number of digits is even."
	elseif #n < 3 then
		return "Error: the number has less than 3 digits."
	end

	local l = math.floor(#n/2)
	return n:sub(l, l+2)
end

-- test
do
	local t = {123, 12345, 1234567, 987654321,
	10001, -10001, -123, -100, 100, -12345, 1,
	2, -1, -10, 2002, -2002, 0}

	for _,n in pairs(t) do
		print(n, middle_three(n))
	end
end


middleDigits := proc(n)
	local nList, start;
	nList := [seq(parse(i), i in convert (abs(n), string))];
	if numelems(nList) < 3 then
		printf ("%9a: Error: Not enough digits.", n);
	elif numelems(nList) mod 2 = 0 then
		printf ("%9a: Error: Even number of digits.", n);
	else
		start := (numelems(nList)-1)/2;
		printf("%9a: %a%a%a", n, op(nList[start..start+2]));
	end if;
end proc:

a := [123, 12345, 1234567, 987654321, 10001, -10001, -123, -100, 100, -12345,
	 1, 2, -1, -10, 2002, -2002, 0]:
for i in a do
	middleDigits(i);
	printf("\n");
end do;


middleThree[n_Integer] :=
 Block[{digits = IntegerDigits[n], len},
  len = Length[digits];
  If[len < 3 || EvenQ[len], "number digits odd or less than 3",
   len = Ceiling[len/2];
   StringJoin @@ (ToString /@ digits[[len - 1 ;; len + 1]])]]

testData = {123, 12345, 1234567, 987654321, 10001, -10001, -123, -100,
    100, -12345, 1, 2, -1, -10, 2002, -2002, 0};

Column[middleThree /@ testData]


function s=middle_three_digits(a)
% http://rosettacode.org/wiki/Middle_three_digits

s=num2str(abs(a));

if ~mod(length(s),2)
	s='*** error: number of digits must be odd ***';
	return;
end;
if length(s)<3,
	s='*** error: number of digits must not be smaller than 3 ***';
	return;
end;

s = s((length(s)+1)/2+[-1:1]);


middle3 = function(num)
    if num < 0 then num = -num
    s = str(num)
    if s.len < 3 then return "Input too short"
    if s.len % 2 == 0 then return "Input length not odd"
    mid = (s.len + 1) / 2 - 1
    return s[mid-1:mid+2]
end function

for test in [123, 12345, 1234567, 987654321, 10001, -10001, -123, -100,
 100, -12345, 1, 2, -1, -10, 2002, -2002, 0]
    print test + " --> " + middle3(test)
end for


	val test_array = ["123","12345","1234567","987654321","10001","~10001","~123","~100","100","~12345","1","2","~1","~10","2002","~2002","0"];

	fun even (x rem 2 = 0) = true | _ = false;

	fun middleThreeDigits
			(h :: t, s, 1 ) = s @ " --> too small"
		|	(h :: t, s, 2 ) = s @ " --> has even digits"
		|	(h :: t, s, 3 ) where (len (h :: t) = 3) = s @ " --> " @ (implode (h :: t))
		|	(h :: t, s, 3 ) = (middleThreeDigits ( sub (t, 0, (len t)-1), s, 3))
		|	(h :: t, s, m) = if len (h :: t) < 3 then
							middleThreeDigits (h :: t, s, 1)
						  else
						    if even ` len (h :: t) then
							  middleThreeDigits (h :: t, s, 2)
							else
							  middleThreeDigits (h :: t, s, 3)

		|	s	= if sub (s, 0, 1) = "~" then
				middleThreeDigits (sub (explode s, 1, len s), s, 0)
			else
				middleThreeDigits (explode s, s, 0)
	;

	map (println o middleThreeDigits) test_array;


/* NetRexx */
options replace format comments java crossref symbols nobinary

sl = '123 12345 1234567 987654321 10001 -10001 -123 -100 100 -12345' -
     '1 2 -1 -10 2002 -2002 0' -
     'abc 1e3 -17e-3 4004.5 12345678 9876543210' -- extras

parse arg digsL digsR .
if \digsL.datatype('w') then digsL = 3
if \digsR.datatype('w') then digsR = digsL
if digsL > digsR        then digsR = digsL

loop dc = digsL to digsR
  say 'Middle' dc 'characters'
  loop nn = 1 to sl.words()
    val = sl.word(nn)
    say middleDigits(dc, val)
    end nn
  say
  end dc
return

-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
method middle3Digits(val) constant
  return middleDigits(3, val)

-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
method middleDigits(digitCt, val) constant
  text = val.right(15)':'
  even = digitCt // 2 == 0 -- odd or even?
  select
    when digitCt <= 0                       then text = 'digit selection size must be >= 1'
    when \val.datatype('w')                 then text = text 'is not a whole number'
    when val.abs().length < digitCt         then text = text 'has less than' digitCt 'digits'
    when \even & val.abs().length // 2 == 0 then text = text 'does not have an odd number of digits'
    when even  & val.abs().length // 2 \= 0 then text = text 'does not have an even number of digits'
    otherwise do
      val = val.abs()
      valL = val.length
      cutP = (valL - digitCt) % 2
      text = text val.substr(cutP + 1, digitCt)
      end
    catch NumberFormatException
      text = val 'is not numeric'
    end
  return text


(define (middle3 x)
    (if (even? (length x))
        (println "You entered " x ". I need an odd number of digits, not " (length x) ".")
        (if (< (length x) 3)
            (println "You entered " x ". Sorry, but I need 3 or more digits.")
            (println "The middle 3 digits of " x " are " ((- (/ (- (length x) 1) 2) 1) 3 (string (abs x))) ".")
        )
    )
)

(map middle3 lst)


proc middleThreeDigits(i: int): string =
  var s = $abs(i)
  if s.len < 3 or s.len mod 2 == 0:
    raise newException(ValueError, "Need odd and >= 3 digits")
  let mid = s.len div 2
  return s[mid-1..mid+1]

const passing = @[123, 12345, 1234567, 987654321, 10001, -10001, -123, -100, 100, -12345]
const failing = @[1, 2, -1, -10, 2002, -2002, 0]

for i in passing & failing:
  var answer = try: middleThreeDigits(i)
               except ValueError: getCurrentExceptionMsg()
  echo "middleThreeDigits(", i, ") returned: ", answer


let even x = (x land 1) <> 1

let middle_three_digits x =
  let s = string_of_int (abs x) in
  let n = String.length s in
  if n < 3 then failwith "need >= 3 digits" else
  if even n then failwith "need odd number of digits" else
  String.sub s (n / 2 - 1) 3

let passing = [123; 12345; 1234567; 987654321; 10001; -10001; -123; -100; 100; -12345]
let failing = [1; 2; -1; -10; 2002; -2002; 0]

let print x =
  let res =
    try (middle_three_digits x)
    with Failure e -> "failure: " ^ e
  in
  Printf.printf "%d: %s\n" x res

let () =
  print_endline "Should pass:";
  List.iter print passing;
  print_endline "Should fail:";
  List.iter print failing;
;;


: middle3
| s sz |
   abs asString dup ->s size ->sz
   sz 3 <    ifTrue: [ "Too short" println return ]
   sz isEven ifTrue: [ "Not odd number of digits" println return ]
   sz 3 - 2 / 1+  dup 2 + s extract ;